packages feed

ampersand (empty) → 3.0.0

raw patch · 107 files changed

+23244/−0 lines, 107 filesdep +SpreadsheetMLdep +ampersanddep +basebuild-type:Customsetup-changed

Dependencies added: SpreadsheetML, ampersand, base, bytestring, containers, directory, filepath, graphviz, hashable, mtl, old-locale, pandoc, pandoc-types, process, split, time, utf8-string

Files

+ AmpersandData/Examples/Delivery/Delivery.adl view
@@ -0,0 +1,277 @@+CONTEXT Delivery -- 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/RepoRap/AST.adl view
@@ -0,0 +1,216 @@+CONTEXT RAP
+
+PATTERN Contexts
+IDENT Context: Context(ctxnm)
+
+ctxnm  ::Context->Conid [INJ]
+MEANING IN ENGLISH "The name of a context."
+ctxpats::Context*Pattern
+MEANING IN ENGLISH "The patterns in a context."
+ctxcs  ::Context*Concept
+MEANING IN ENGLISH "A concept, mentioned anywhere in a context, is declared."
+ctxgE :: Context*GenR
+MEANING IN ENGLISH "The generalization relation of a concept."
+
+ENDPATTERN
+
+PATTERN Patterns
+IDENT Pattern: Pattern(ptnm)
+
+ptnm  :: Pattern->Conid [INJ]
+MEANING IN ENGLISH "The name of a pattern."
+ptrls :: Pattern*Rule
+MEANING IN ENGLISH "The user-defined rules in a pattern."
+ptgns :: Pattern*Gen
+MEANING IN ENGLISH "The user-defined generalization rules in a pattern."
+ptdcs :: Pattern*Declaration
+MEANING IN ENGLISH "The relation declarations in a pattern."
+ptxps :: Pattern*Blob
+MEANING IN ENGLISH "The purposes of a pattern."
+ptctx :: Pattern*Context PRAGMA "" "is used in" -- @Han, wil je deze relatie toevoegen en invullen met de inhoud van ctxpats~    Uitleg volgt mondeling.
+ENDPATTERN
+
+PATTERN Gens
+IDENT Gen: Gen( genspc, gengen )
+VIEW Gen: Gen( TXT "CLASSIFY ", genspc;cptnm , TXT " ISA " , gengen;cptnm )
+RULE "eq gen": gengen;gengen~ /\ genspc;genspc~ |- I[Gen]
+MEANING IN ENGLISH "Two generalization rules are identical when the specific concepts are identical and the generic concepts are identical."
+
+gengen :: Gen->PlainConcept
+MEANING IN ENGLISH "A generalization rule refers to a more generic concept."
+genspc :: Gen->PlainConcept
+MEANING IN ENGLISH "A generalization rule refers to a more specific concept."
+
+ENDPATTERN
+
+PATTERN Concepts
+SPEC PlainConcept ISA A_Concept
+SPEC ConceptOne ISA A_Concept
+
+IDENT PlainConcept: PlainConcept(cptnm)
+
+cptnm :: PlainConcept->Conid [INJ]
+MEANING IN ENGLISH "The name of a concept."
+context :: PlainConcept*Context --@Stef: Willen we dit opnemen? of is dit dezelfde relatie als ctxcs? (maar daar hebben we het alleen over de definities, dus dit is wellicht een andere relatie.
+MEANING IN ENGLISH "The context where the concept is known."
+cpttp :: PlainConcept -> Blob 
+MEANING IN ENGLISH "The type of this Concept"
+cptdf :: PlainConcept*Blob
+MEANING IN ENGLISH "The definitions of a concept."
+cptpurpose :: PlainConcept*Blob
+MEANING IN ENGLISH "The purposes of a concept."
+
+
+{- obsolete
+-- CONCEPT Order "The order of the is-a-relation between concepts."
+-- IDENT Order: Order(ordername)
+-- SPEC PlainConcept ISA Concept
+-- SPEC "ONE" ISA Concept
+-- ordername :: Order -> String [INJ]
+-- MEANING IN ENGLISH "The name of a class of is-a-related concepts."
+-- order :: PlainConcept -> Order
+-- MEANING IN ENGLISH "A concept belongs to a class of is-a-related concepts."
+-- RULE "order": order~;genspc~;gengen;order |- I
+-- MEANING IN ENGLISH "Is-a-related concepts belong to the same class of is-a-related concepts."
+--RULE "different order": ???, a closure would be nice...
+--MEANING IN ENGLISH "Concepts, that are not is-a-related, are in different orders of the is-a-relation."
+
+--NOTE: MESSAGEs depend on the edit possibilities of the interface they are used in.
+--if you have written messages for interfaces at a certain moment and you add an interface which can violate a message differently, then you should revise those messages, but probably you will forget to do so -> risk for awkward messages in new interface
+-}
+
+
+--RULE "referential integrity": src~;decsgn~;decpopu;left \/ trg~;decsgn~;decpopu;right |- order;order~;cptos
+--MEANING IN ENGLISH "An atom in the domain or codomain of a relation is an instance of a concept from the same class as the source respectively the target of that relation."
+--MESSAGE "If an atom is in some tuple of a relation, then that atom must exist in the concept that is the source respectively target of that relation. Deletion of an atom from a concept is not permitted if that atom is still present in some tuple of some relation. Nor is addition of a tuple permitted if the source or target atom is not present in the related concept. It is a violation of <b>Referential integrity</b> rule for a relation." 
+--VIOLATION (TXT "The tuple ", SRC I, TXT " refers to a source or target atom that does not exist." )
+ENDPATTERN
+
+PATTERN Populations
+
+SPEC RelPopu ISA Population
+SPEC CptPopu ISA Population
+
+popdcl::RelPopu->Declaration
+popps::RelPopu*Pair
+
+popcpt::CptPopu->A_Concept
+popas::CptPopu*Atom
+
+IDENT Pair: Pair( left;atomvalue, right;atomvalue )
+VIEW Pair: Pair( left;atomvalue , TXT " * " , right;atomvalue )
+left::Pair->Atom
+MEANING IN ENGLISH "The source of a relationship."
+right::Pair->Atom
+MEANING IN ENGLISH "The target of a relationship."
+
+
+IDENT Atom: Atom( atomvalue,root)
+VIEW Atom: Atom( atomvalue , TXT " :: ", root)
+atomvalue::Atom->AtomValue
+MEANING IN ENGLISH "The value of an atom."
+--RULE "entity integrity concept": atomvalue;atomvalue~ /\ popas~;order;order~;popas |- I
+--MEANING IN ENGLISH "An atom of a concept has a unique value within the class of that concept."
+--MESSAGE "Every atom of a concept is unique, or, no two atoms in the population of a concept have the same name. Addition of a duplicate atom is not permitted. It is a violation of the <b>Entity integrity</b> rule for this concept. Please refer to book <i>Rule Based Design</i>, page 43 and 52, <i>entity integrity</i>. "
+--VIOLATION (TXT "An atom with name ", SRC I, TXT " already exists." )
+root::Atom->A_Concept
+MEANING IN ENGLISH "The root concept of an atom."
+-- an atom representing `Piet` as an instance of the concept `Student`, could have `Person` as root concept of that atom. (assuming Student ISA Person) 
+ENDPATTERN
+
+PATTERN Signs
+IDENT Sign: Sign( src, trg )
+-- VIEW Sign: Sign( src;name[Concept*Conid] , TXT " * " , trg;name[Concept*Conid] )
+src::Sign->A_Concept
+MEANING IN ENGLISH "The source of a sign."
+trg::Sign->A_Concept
+MEANING IN ENGLISH "The target of a sign."
+
+ENDPATTERN
+
+PATTERN Declarations
+IDENT Declaration: Declaration( decnm , decsgn;src, decsgn;trg )
+VIEW Declaration: Declaration( decnm , TXT " :: ", decsgn;src;cptnm ,TXT " * ", decsgn;trg;cptnm )
+RULE "eq declaration": decnm;decnm~ /\ decsgn;src;(decsgn;src)~ /\ decsgn;trg;(decsgn;trg)~ |- I
+MEANING IN ENGLISH "The unique signature of a relation consists of a relation name, a source concept, and a target concept."
+-- HJO20130509: There should be a rule that ONE must not be source and/or target of a Declaration
+decnm   ::Declaration->Varid
+MEANING IN ENGLISH "The name of a relation."
+decsgn ::Declaration->Sign
+MEANING IN ENGLISH "The sign of a declaration."
+decprps::Declaration*PropertyRule [INJ]
+MEANING IN ENGLISH "The properties of a relation."
+
+SPEC PropertyRule ISA Rule
+RULE "property enum": I[Property] |- '->' \/ 'UNI' \/ 'TOT' \/ 'INJ' \/ 'SUR' \/ 'RFX' \/ 'IRF' \/ 'SYM' \/ 'ASY' \/ 'TRN' \/ 'PROP'
+MEANING IN ENGLISH "There are eleven tokens, that can be used to define properties on a relation. -> means univalent and total; UNI means univalent; TOT means total; INJ means injective; SUR means surjective; RFX means reflexive; IRF means irreflexive; SYM means symmetric; ASY means antisymmetric; TRN means transitive; and PROP means symmetric and antisymmetric."
+declaredthrough::PropertyRule*Property [TOT]
+MEANING IN ENGLISH "A property is defined as part of the declaration of relation."
+
+decprL  ::Declaration*String[UNI]
+MEANING IN ENGLISH "The prefix of the pragma of a relation."
+decprM  ::Declaration*String[UNI]
+MEANING IN ENGLISH "The infix of the pragma of a relation."
+decprR  ::Declaration*String[UNI]
+MEANING IN ENGLISH "The suffix of the pragma of a relation."
+decmean ::Declaration * Blob
+MEANING IN ENGLISH "The meanings of a relation."
+decpurpose::Declaration * Blob
+MEANING IN ENGLISH "The purposes of a relation."
+decpopu ::Declaration->RelPopu
+MEANING IN ENGLISH "The population of a relation."
+
+RULE "entity integrity of relation": left;left~ /\ right;right~ /\ popps~;popps |- I[Pair]
+MEANING IN ENGLISH "There cannot be two pairs in the population of a relation with the same source and same target."
+MESSAGE "Every tuple in a relation is unique, or, no two tuples in the population of a relation may have the same source and target atoms. Addition of a duplicate tuple is not permitted. It is a violation of the <b>Entity integrity</b> rule for this relation."
+VIOLATION (TXT "A tuple with the same source and target atoms ", SRC I[Pair], TXT " already exists." )
+
+-- Onderstaande regel is afleidbaar, en hoeft derhalve niet gechecked te worden. We laten de regel echter hier wel staan
+RULE "typed domain": decpopu;popps;left;popas~  |- decsgn;src;popcpt~
+MEANING IN ENGLISH "The atoms in the domain of a relation belong to the same class as the source of that relation."
+MESSAGE "You try to add a tuple with a source atom, that is not in the population of the source of the relation. This is a violation of the type of the tuple. TIP: enter text in the left input field to get a shorter pick list. Note on ISA-relations: You can make an atom more specific by moving it to the population of a more specific concept."
+VIOLATION (TXT "Source atom ", TGT I[CptPopu], TXT " is not in the population of ", SRC decsgn;src)
+
+RULE "typed codomain": decpopu;popps;right;popas~ |- decsgn;trg;popcpt~
+MEANING IN ENGLISH "The atoms in the codomain of a relation belong to the same class as the target of that relation."
+MESSAGE "You try to add a tuple with a target atom, that is not in the population of the target of the relation. This is a violation of the type of the tuple. TIP: enter text in the right input field to get a shorter pick list. Note on ISA-relations: You can make an atom more specific by moving it to the population of a more specific concept."
+VIOLATION (TXT "Target atom ", TGT I[CptPopu], TXT " is not in the population of ", SRC decsgn;trg)
+ENDPATTERN
+
+PATTERN Expressions
+IDENT ExpressionID : ExpressionID(exprvalue)
+
+exprvalue :: ExpressionID->Expression
+MEANING IN ENGLISH "The value of an expression."
+rels  :: ExpressionID*Declaration
+MEANING IN ENGLISH "The user-declared relations in an expression."
+
+--CONCEPT Relation "A relation is a relation term in an expression linked to a user-declared relation"
+--IDENT Relation: Relation( relnm , relsgn;src, relsgn;trg)
+--VIEW Relation: Relation( relnm , TXT "[" , relsgn;src;name[Concept*Conid] , TXT "*" , relsgn;trg;name[Concept*Conid] , TXT "]")
+
+--relnm :: Relation -> Varid
+--MEANING IN ENGLISH "The name of a relation used as a relation token."
+--relsgn:: Relation -> Sign
+--MEANING IN ENGLISH "The sign of a relation."
+--reldcl:: Relation -> Declaration
+--MEANING IN ENGLISH "A relation token refers to a relation."
+--RULE "rel name is decl name": relnm = reldcl;decnm
+--MEANING IN ENGLISH "The name of a relation is used as a relation token to refer to that relation."
+ENDPATTERN
+
+PATTERN Rules
+IDENT Rule: Rule(rrnm)
+
+rrnm  :: Rule -> ADLid [INJ]
+MEANING IN ENGLISH "The name of a rule."
+rrexp :: Rule -> ExpressionID
+MEANING IN ENGLISH "The rule expressed in relation algebra."
+rrmean:: Rule * Blob
+MEANING IN ENGLISH "The meanings of a rule."
+rrpurpose:: Rule * Blob
+MEANING IN ENGLISH "The purposes of a rule."
+ENDPATTERN
+ENDCONTEXT
+
+
+ AmpersandData/RepoRap/ASTdocumentation.adl view
@@ -0,0 +1,214 @@+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 -}
+PURPOSE CONTEXT RAP IN ENGLISH LATEX
+{+RAP is a Repository for Ampersand Projects.
+Its purpose is to provide a collaboration platform to groups of designers who work on Ampersand projects.
+This document is a step on the way of specifying RAP.
+It has largely been generated by the Ampersand toolset.
+-}
+-- Context
+CONCEPT Context "A context is a set of statements in a formal language that are true within that context."
+     --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.A_Context(ctxnm,ctxpats,ctxcs):svn1020"
+PURPOSE CONCEPT Context IN ENGLISH LATEX
+{+
+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 Contexts IN ENGLISH LATEX
+{+The rules that govern contexts are brought together in one pattern,
+in order to formalize contexts and determine their meaning.
+-}
+
+-- Rule
+CONCEPT Rule "A rule is a statement that must be true in each context in which it is valid."
+  --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.Rule(rrnm,rrexp):svn1020"
+PURPOSE CONCEPT Rule IN ENGLISH LATEX
+{+
+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 Rules IN ENGLISH LATEX
+{+The rules that govern rules are brought together in one pattern,
+in order to formalize rules and determine their meaning.
+-}
+
+-- Pattern
+CONCEPT Pattern "A pattern is a set of rules that describes a theme or a general reusable solution to a commonly occurring problem."
+     --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.Pattern(ptnm,ptdcs,ptgns,ptrls):svn1020"
+PURPOSE CONCEPT Pattern IN ENGLISH LATEX
+{+
+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.
+-}
+PURPOSE PATTERN Patterns IN ENGLISH LATEX
+{+The rules that govern patterns are brought together in one pattern,
+in order to formalize patterns and determine their meaning.
+-}
+
+-- Expression
+CONCEPT ExpressionID "An expressionID identifies an expression with a context-dependent meaning e.g. a rule assertion, a signal relation, or a relation."
+CONCEPT Expression "An expression is a relation algebraic term, denoted in Ampersand syntax"
+        --    "DatabaseDesign.Ampersand.Input.ADL1.Parser.pExpr:svn1020"
+PURPOSE CONCEPT Expression IN ENGLISH LATEX
+{+
+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.
+-}
+PURPOSE PATTERN Expressions IN ENGLISH LATEX
+{+The rules that govern expressions are brought together in one pattern,
+in order to formalize expressions and determine their meaning.
+-}
+
+-- Concept
+CONCEPT A_Concept "A concept is a name for a category of similar objects."
+ --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.A_Concept(cptnm,cptdf,cptos):svn1020"
+CONCEPT ConceptOne "ConceptOne, also known as ONE, is a predefined concept that has the role of universal singleton"
+CONCEPT PlainConcept "A concept is a name for a category of similar objects."
+PURPOSE CONCEPT PlainConcept IN ENGLISH LATEX
+{+
+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.
+-}
+PURPOSE PATTERN Concepts IN ENGLISH LATEX
+{+The rules that govern concepts are brought together in one pattern,
+in order to formalize concepts and determine their meaning.
+-}
+
+-- Atom
+CONCEPT AtomID "An atomID is the identity of an atomic term."
+CONCEPT Atom "An atom is an indivisible (unstructured) data element, and an instance of a specific concept." TYPE "Blob"
+  --    "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pAtom:svn1020"
+CONCEPT AtomValue "An atom is the value of an atomic term." TYPE "Blob"
+  --    "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pAtom:svn1020"
+PURPOSE CONCEPT Atom IN ENGLISH LATEX
+{+
+Atoms are used to represent data. They are stored in relations that reside within a context.
+\subsubsection*{Example}
+For example, the atom ``Amsterdam'' is an instance of the concept ``City''.
+\subsubsection*{Explanation}
+Atoms populate relations.
+Ampersand works with binary relations, so you will find pairs of atoms in a relation.
+In an information system, the population of relations can change because of edit actions by users in user interfaces.
+This means that pairs are inserted into and deleted from relations as time goes by.
+-}
+PURPOSE PATTERN Populations IN ENGLISH LATEX
+{+The rules that govern atoms, pairs, and populations are brought together in one pattern,
+in order to formalize them and determine their meaning.
+-}
+
+CONCEPT Population "The contents of a Concept or Relation"
+PURPOSE CONCEPT Population IN ENGLISH LATEX
+{+
+Populations are a means to specify a number of true statements that are stored in a relation.
+If an information system is generated, the population specified in an Ampersand script
+is used as the initial data stored in the database.
+This data can subsequently be changed by performing transactions on that database.
+\subsubsection*{Example}
+\begin{verbatim}
+  POPULATION address[Person,Address] CONTAINS
+  { ("Peter", "148 Browning Street")
+  ; ("Susan", "Dorpsstraat 78")
+  ; ("Bart",  "2013 McGinnigall Drive")
+  }
+\end{verbatim}
+\subsubsection*{Explanation}
+Populations provide the initial content of a database. 
+
+The word {\emph population} is used sloppily for contexts as well.
+It refers the the total of all populations in relations and concepts inside that context.
+-}
+
+CONCEPT RelPopu "The content of a relation"
+CONCEPT CptPopu "The content of a concept"
+CONCEPT Pair "A pair of atomic terms as an instance of an element with a sign e.g. the population of a relation or the violations of a rule"
+CONCEPT Blob "A blob is a pString expected to need more than 256 characters of reserved space." TYPE "Blob"
+  --    "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pString:svn1020"
+CONCEPT String "A string is a pString expected to be less than 256 characters."
+    --    "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pString:svn1020"
+CONCEPT Conid "A conid is an identifier starting with an uppercase"
+   --    "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pConid:svn1020"
+CONCEPT Varid "A varid is an identifier starting with a lowercase"
+   --    "DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.pVarid:svn1020"
+CONCEPT ADLid "An ADLid is an identifier of type pVarid <|> pConid <|> pString"
+   --    "DatabaseDesign.Ampersand.Input.ADL1.Parser.pADLid:svn1020"
+CONCEPT Gen "A gen, or generalization rule, is the is-a-relation between a more specific and a more generic concept."
+ --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.A_Gen(genspc,gengen):svn1020"
+CONCEPT Sign "A sign is a relation type signature consisting of a source concept and a target concept."
+  --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.Sign:svn1020"
+CONCEPT PairID "A pairID is an identifier for a pair of atomic terms as an instance of an element with a sign e.g. the population of a relation or the violations of a rule"
+CONCEPT Declaration "A declaration is a declaration of a relation with a sign and properties of that relation"
+         --    "DatabaseDesign.Ampersand.Core.AbstractSyntaxTree.Declaration(decnm,decsgn,decprps):svn1020"
+CONCEPT PropertyRule "A property rule is a rule, that is a property of a user-declared relation"
+          --    "DatabaseDesign.Ampersand.ADL1.Rule.rulefromProp:svn1020"
+CONCEPT Property "..->.. or UNI<|>TOT<|>INJ<|>SUR<|>RFX<|>IRF<|>SYM<|>ASY<|>TRN<|>PROP"
+      --    "DatabaseDesign.Ampersand.ADL1.Prop.Prop(..):svn1020"
+CONCEPT Relation "A relation is a relation term in an expression linked to a user-declared relation"
+ENDCONTEXT
+ AmpersandData/RepoRap/Fspec.adl view
@@ -0,0 +1,30 @@+CONTEXT RAP
+INCLUDE "AST.adl"
+
+PATTERN Image
+imageurl :: Image*URL
+MEANING IN ENGLISH "The location of an image on the Internet."
+VIEW Image: Image(PRIMHTML "<img src='", imageurl , PRIMHTML "'>")
+ENDPATTERN
+
+PATTERN Conceptual
+ptpic::Pattern*Image[UNI]
+MEANING IN ENGLISH "A conceptual diagram for a pattern."
+cptpic::PlainConcept*Image[UNI]
+MEANING IN ENGLISH "A conceptual diagram for a concept."
+rrpic::Rule*Image[UNI]
+MEANING IN ENGLISH "A conceptual diagram for a rule."
+ENDPATTERN
+
+PATTERN RuleEnforcement
+SPEC Violation ISA Pair
+rrviols::Rule*Violation
+MEANING IN ENGLISH "The violations of a rule."
+ENDPATTERN
+
+PATTERN Misc
+CONCEPT PragmaSentence "An example sentence using the pragma of a relation declaration." TYPE "Blob"
+decexample :: Declaration * PragmaSentence
+MEANING IN ENGLISH "An example sentence using the pragma of a relation."
+ENDPATTERN
+ENDCONTEXT
+ AmpersandData/RepoRap/RAP.adl view
@@ -0,0 +1,185 @@+CONTEXT RAP 
+--INCLUDE "student_AST_interfaces.adl"
+--INCLUDE "admin_interfaces.adl"
+INCLUDE "Fspec.adl"
+INCLUDE "ASTdocumentation.adl"
+IN ENGLISH
+LATEX
+
+PROCESS AtlasLoad1
+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[RelPopu], TXT " of ", TGT (inipopu\/decpopu)~)
+
+
+RULE "parseerror": parseerror |- V[File*ParseError]-parseerror
+MESSAGE "<span class='errsignal'>A syntax error was encountered in your script.</span> No CONTEXT screen could be generated."
+VIOLATION (TGT I[ParseError], TXT " Open ", SRC I[File],TXT " to fix error.")
+
+RULE "typeerror": typeerror |- V[File*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[TypeError], TXT ". Open ", SRC I[File],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")
+
+--HJO, 20130723: Temporarily disabled the following rules, for they give problems. (and besides, what is the meaning of the rules????, there is no explicit purpose!)
+RULE "multviolations1": V[Rule*Violation]-((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[Rule], TXT " is violated by the atom ", TGT I[Violation];left, TXT ".")
+
+RULE "multviolations2": V[Rule*Violation]-((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[Rule], TXT " is violated by the tuple ", TGT I[Violation], TXT " in combination with some other tuple(s).")
+
+RULE "multviolations3": V[Rule*Violation]-((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[Rule], TXT " is violated by the tuple ", TGT I[Violation], TXT " in combination with some other tuple(s).")
+
+RULE "homoviolations": V[Rule*Violation]-((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[Rule], TXT " is violated by the tuple ", TGT I[Violation], TXT " in combination with some other tuple(s).")
+
+RULE "otherviolations": V[Rule*Violation]-((I[Rule]-I[PropertyRule]);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 tuple ", TGT I[Violation], 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 AtlasLoad2
+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*CptPopu
+MEANING IN ENGLISH "The initial population of a concept from a rule specification file."
+inipopu::Declaration*RelPopu
+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"
+VIEW 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."
+VIEW 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"
+VIEW 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[File]
+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
+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."
+VIEW G: G(PRIMHTML "<a href='../../index.php?operation=",operation
+         ,PRIMHTML "&file=", applyto;filepath , applyto;filename
+         ,PRIMHTML "&userrole=", applyto;uploaded~;userrole
+         ,PRIMHTML "'>", functionname, PRIMHTML "</a>"
+         )
+
+
+SPEC NewAdlFile ISA AdlFile
+VIEW NewAdlFile: NewAdlFile(PRIMHTML "<a href='../../index.php'>",I[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
+VIEW SavePopFile: SavePopFile(PRIMHTML "<a href='../../index.php?operation=4&file=", I[SavePopFile];filepath , I[SavePopFile];filename
+                            ,PRIMHTML "'>", I[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
+VIEW SaveAdlFile: SaveAdlFile(PRIMHTML "<a href='../../index.php?operation=2&file=", I[SaveAdlFile];filepath , I[SaveAdlFile];filename
+                            ,PRIMHTML "&userrole=", savecontext~;sourcefile;uploaded~;userrole
+                            ,PRIMHTML "'>", I[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/RepoRap/README.txt view
@@ -0,0 +1,2 @@+[HJO, 12 march 2013:]
+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/RepoRap/admin_interfaces.adl view
@@ -0,0 +1,20 @@+CONTEXT Atlas
+INTERFACE "Files" FOR Admin: I[ONE]
+BOX ["loaded files": V[ONE*File];(sourcefile~;sourcefile \/ parseerror;parseerror~ \/ typeerror;typeerror~)
+    BOX ["name":filename
+        ,"dir":filepath
+        ,"created at":filetime
+        ,"first loaded with":firstloadedwith
+        ,"syntax error":parseerror BOX [act:pe_action,pos:pe_position,exp:pe_expecting]
+        ,"type error":typeerror BOX [msg:te_message]
+        ,"context" : sourcefile~ 
+        BOX ["name":ctxnm
+            ,"source files":(sourcefile \/ includes);filename
+            ,"number of rules":countrules
+            ,"number of declarations":countdecls
+            ,"number of concepts":countcpts] 
+    ]
+]
+ENDCONTEXT
+
+
+ AmpersandData/RepoRap/student_AST_interfaces.adl view
@@ -0,0 +1,199 @@+CONTEXT RAP
+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;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*PlainConcept];(I[PlainConcept]-(cptdf;cptdf~))
+    , "relations without MEANING": V[ONE*Declaration];(-(decmean;decmean~) /\ I) -- -(V[ONE*Blob];decmean~)
+    , "RULEs without MEANING": V[ONE*Rule];(I[Rule]-(rrmean;rrmean~)) -- -(V[ONE*Blob];rrmean~)
+    , "populated relations": V[ONE*RelPopu];decpopu~
+    , "unpopulated relations": V[ONE*Declaration];(I-(decpopu;decpopu~)) -- -(V[ONE*PairID];decpopu~)
+--INCORRECT    , "relations not in any RULE (provided that a RULE exists)": V[ONE*Rule];(I[Rule] /\ -I[PropertyRule]);-(rrexp;rels;reldcl)
+    ]
+
+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"(popas,atomvalue) FOR Student: I[PlainConcept]
+BOX ["PURPOSEs" :cptpurpose
+    ,"CONCEPT definition" :cptdf
+    ,"name" :cptnm
+    ,"POPULATION" :popcpt~;popas 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[PlainConcept], "POPULATION":popcpt~;popas;atomvalue]
+    ,"more generic concepts" : genspc~;gengen \/ genspc~;gengen;genspc~;gengen \/ genspc~;gengen;genspc~;gengen;genspc~;gengen   --TODO closure
+--    ,"comparable atoms":order;order~;popas BOX ["atom":atomvalue, "of concept":popas~]
+    ,"used in relations": (decsgn;(src \/ trg))~
+--    ,"used in RULEs": (rrexp;rels;decsgn;(src \/ trg))~;(I[Rule]-I[PropertyRule])
+    ,"diagram" : cptpic
+    ]
+INTERFACE "Atom"(atomvalue) FOR Student: I[Atom]
+BOX ["atom": atomvalue
+    ,"in POPULATION of": popas~]
+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;popps BOX ["source":left , "target":right] --select existing atoms only!
+--    ,"used in RULEs": (rrexp;rels)~;(I[Rule]-I[PropertyRule])
+    ]
+INTERFACE "RULE" FOR Student: I[Rule]
+BOX ["PURPOSEs" :rrpurpose
+    ,"MEANING" :rrmean
+    ,"name" :rrnm
+    ,"assertion" :rrexp
+    ,"uses":rrexp;rels BOX ["relation":I, "with properties": decprps;declaredthrough, "source":decsgn;src, "target":decsgn;trg]
+    ,"in PATTERN":ptrls~
+    ,"diagram" : rrpic
+    ]
+ENDCONTEXT
+
+
+ LICENSE view
@@ -0,0 +1,621 @@+                    GNU GENERAL PUBLIC LICENSE
+                       Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+                            Preamble
+
+  The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+  The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works.  By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users.  We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors.  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+  To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights.  Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received.  You must make sure that they, too, receive
+or can get the source code.  And you must show them these terms so they
+know their rights.
+
+  Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+  For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software.  For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+  Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so.  This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software.  The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable.  Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products.  If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+  Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary.  To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+                       TERMS AND CONDITIONS
+
+  0. Definitions.
+
+  "This License" refers to version 3 of the GNU General Public License.
+
+  "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+  "The Program" refers to any copyrightable work licensed under this
+License.  Each licensee is addressed as "you".  "Licensees" and
+"recipients" may be individuals or organizations.
+
+  To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy.  The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+  A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+  To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy.  Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+  To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies.  Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+  An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License.  If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+  1. Source Code.
+
+  The "source code" for a work means the preferred form of the work
+for making modifications to it.  "Object code" means any non-source
+form of a work.
+
+  A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+  The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form.  A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+  The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities.  However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work.  For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+  The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+  The Corresponding Source for a work in source code form is that
+same work.
+
+  2. Basic Permissions.
+
+  All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met.  This License explicitly affirms your unlimited
+permission to run the unmodified Program.  The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work.  This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+  You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force.  You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright.  Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+  Conveying under any other circumstances is permitted solely under
+the conditions stated below.  Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+  3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+  No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+  When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+  4. Conveying Verbatim Copies.
+
+  You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+  You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+  5. Conveying Modified Source Versions.
+
+  You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+    a) The work must carry prominent notices stating that you modified
+    it, and giving a relevant date.
+
+    b) The work must carry prominent notices stating that it is
+    released under this License and any conditions added under section
+    7.  This requirement modifies the requirement in section 4 to
+    "keep intact all notices".
+
+    c) You must license the entire work, as a whole, under this
+    License to anyone who comes into possession of a copy.  This
+    License will therefore apply, along with any applicable section 7
+    additional terms, to the whole of the work, and all its parts,
+    regardless of how they are packaged.  This License gives no
+    permission to license the work in any other way, but it does not
+    invalidate such permission if you have separately received it.
+
+    d) If the work has interactive user interfaces, each must display
+    Appropriate Legal Notices; however, if the Program has interactive
+    interfaces that do not display Appropriate Legal Notices, your
+    work need not make them do so.
+
+  A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit.  Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+  6. Conveying Non-Source Forms.
+
+  You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+    a) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by the
+    Corresponding Source fixed on a durable physical medium
+    customarily used for software interchange.
+
+    b) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by a
+    written offer, valid for at least three years and valid for as
+    long as you offer spare parts or customer support for that product
+    model, to give anyone who possesses the object code either (1) a
+    copy of the Corresponding Source for all the software in the
+    product that is covered by this License, on a durable physical
+    medium customarily used for software interchange, for a price no
+    more than your reasonable cost of physically performing this
+    conveying of source, or (2) access to copy the
+    Corresponding Source from a network server at no charge.
+
+    c) Convey individual copies of the object code with a copy of the
+    written offer to provide the Corresponding Source.  This
+    alternative is allowed only occasionally and noncommercially, and
+    only if you received the object code with such an offer, in accord
+    with subsection 6b.
+
+    d) Convey the object code by offering access from a designated
+    place (gratis or for a charge), and offer equivalent access to the
+    Corresponding Source in the same way through the same place at no
+    further charge.  You need not require recipients to copy the
+    Corresponding Source along with the object code.  If the place to
+    copy the object code is a network server, the Corresponding Source
+    may be on a different server (operated by you or a third party)
+    that supports equivalent copying facilities, provided you maintain
+    clear directions next to the object code saying where to find the
+    Corresponding Source.  Regardless of what server hosts the
+    Corresponding Source, you remain obligated to ensure that it is
+    available for as long as needed to satisfy these requirements.
+
+    e) Convey the object code using peer-to-peer transmission, provided
+    you inform other peers where the object code and Corresponding
+    Source of the work are being offered to the general public at no
+    charge under subsection 6d.
+
+  A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+  A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling.  In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage.  For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product.  A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+  "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source.  The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+  If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information.  But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+  The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed.  Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+  Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+  7. Additional Terms.
+
+  "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law.  If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+  When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it.  (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.)  You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+  Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+    a) Disclaiming warranty or limiting liability differently from the
+    terms of sections 15 and 16 of this License; or
+
+    b) Requiring preservation of specified reasonable legal notices or
+    author attributions in that material or in the Appropriate Legal
+    Notices displayed by works containing it; or
+
+    c) Prohibiting misrepresentation of the origin of that material, or
+    requiring that modified versions of such material be marked in
+    reasonable ways as different from the original version; or
+
+    d) Limiting the use for publicity purposes of names of licensors or
+    authors of the material; or
+
+    e) Declining to grant rights under trademark law for use of some
+    trade names, trademarks, or service marks; or
+
+    f) Requiring indemnification of licensors and authors of that
+    material by anyone who conveys the material (or modified versions of
+    it) with contractual assumptions of liability to the recipient, for
+    any liability that these contractual assumptions directly impose on
+    those licensors and authors.
+
+  All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10.  If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term.  If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+  If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+  Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+  8. Termination.
+
+  You may not propagate or modify a covered work except as expressly
+provided under this License.  Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+  However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+  Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+  Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License.  If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+  9. Acceptance Not Required for Having Copies.
+
+  You are not required to accept this License in order to receive or
+run a copy of the Program.  Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance.  However,
+nothing other than this License grants you permission to propagate or
+modify any covered work.  These actions infringe copyright if you do
+not accept this License.  Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+  10. Automatic Licensing of Downstream Recipients.
+
+  Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License.  You are not responsible
+for enforcing compliance by third parties with this License.
+
+  An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations.  If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+  You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License.  For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+  11. Patents.
+
+  A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based.  The
+work thus licensed is called the contributor's "contributor version".
+
+  A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version.  For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+  Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+  In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement).  To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+  If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients.  "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+  If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+  A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License.  You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+  Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+  12. No Surrender of Others' Freedom.
+
+  If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all.  For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+  13. Use with the GNU Affero General Public License.
+
+  Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work.  The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+  14. Revised Versions of this License.
+
+  The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+  Each version is given a distinguishing version number.  If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation.  If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+  If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+  Later license versions may give you additional or different
+permissions.  However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+  15. Disclaimer of Warranty.
+
+  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+  16. Limitation of Liability.
+
+  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+  17. Interpretation of Sections 15 and 16.
+
+  If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+                     END OF TERMS AND CONDITIONS
+ Setup.hs view
@@ -0,0 +1,80 @@+{-# OPTIONS_GHC -Wall #-}  +import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Setup+import Distribution.PackageDescription+--import System.Time+import System.Process+import System.IO+import Control.Exception+import Data.List+import Data.Time.Clock+import Data.Time.Format+import System.Locale++main :: IO ()+main = defaultMainWithHooks (simpleUserHooks { buildHook = generateBuildInfoHook } )++-- Before each build, generate a BuildInfo_Generated module that exports the project version from cabal,+-- the current svn revision number and the build time.+--+-- Note that in order for this Setup.hs to be used by cabal, the build-type should be Custom.++generateBuildInfoHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()+generateBuildInfoHook pd  lbi uh bf = + do { let cabalVersionStr = intercalate "." (map show . versionBranch . pkgVersion . package $ pd)++    ; svnRevisionStr <- do { r <- catch getSVNRevisionStr myHandler +                           ; if r == "" +                             then noSVNRevisionStr+                             else return r+                           }+    ; clockTime <- getCurrentTime +    ; let buildTimeStr = formatTime defaultTimeLocale "%d-%b-%y %H:%M:%S %Z" clockTime+    ; writeFile "src/lib/DatabaseDesign/Ampersand/Basics/BuildInfo_Generated.hs" $+        buildInfoModule cabalVersionStr svnRevisionStr buildTimeStr++    ; (buildHook simpleUserHooks) pd lbi uh bf -- start the build+    }+ where myHandler :: IOException -> IO String+       myHandler err = do { print err+                          ; noSVNRevisionStr+                          }++buildInfoModule :: String -> String -> String -> String+buildInfoModule cabalVersion revision time = unlines+ [ "module DatabaseDesign.Ampersand.Basics.BuildInfo_Generated (cabalVersionStr, svnRevisionStr, buildTimeStr) where"+ , ""+ , "-- This module is generated automatically by Setup.hs before building. Do not edit!"+ , ""+ , "{-# NOINLINE cabalVersionStr #-}" -- disable inlining to prevent recompilation of dependent modules on each build+ , "cabalVersionStr :: String"+ , "cabalVersionStr = \"" ++ cabalVersion ++ "\""+ , ""+ , "{-# NOINLINE svnRevisionStr #-}"+ , "svnRevisionStr :: String"+ , "svnRevisionStr = \"" ++ revision ++ "\""+ , ""+ , "{-# NOINLINE buildTimeStr #-}"+ , "buildTimeStr :: String"+ , "buildTimeStr = \"" ++ time ++ "\""+ ]++getSVNRevisionStr :: IO String+getSVNRevisionStr = + do { (inh,outh,errh,proch) <- runInteractiveProcess "svnversion" ["."] Nothing Nothing+    ; hClose inh+    ; hClose errh+    ; version <- hGetContents outh+    ; _ <- seq version $ waitForProcess proch+    ; return (unwords . lines $ version)+    }++noSVNRevisionStr :: IO String+noSVNRevisionStr =+ do { putStrLn "\n\n\nWARNING: Execution of 'svnversion' command failed."+    ; putStrLn $ "BuildInfo_Generated.hs will not contain revision information, and therefore\nneither will fatal error messages.\n"+++                 "Please find out why the command  'svnversion .' does not work.\n"+++                 "Otherwise (re-)install a subversion client (e.g. 'Slik SVN') that supports\nthe command-line 'svnversion'-command without interfering with your other SVN-clients.\n"+    ; return "??"+    }
+ ampersand.cabal view
@@ -0,0 +1,178 @@+name:           ampersand
+version:        3.0.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
+category:       Database Design
+stability:      alpha
+cabal-version:  >= 1.10
+build-type:     Custom
+license:        GPL
+license-file:   LICENSE
+copyright:      Stef Joosten
+bug-reports:    http://sourceforge.net/apps/trac/ampersand/newticket
+tested-with:    GHC == 7.6.3
+data-files:     
+                AmpersandData/Examples/Delivery/Delivery.adl, 
+                AmpersandData/RepoRap/admin_interfaces.adl, 
+                AmpersandData/RepoRap/AST.adl, 
+                AmpersandData/RepoRap/ASTdocumentation.adl, 
+                AmpersandData/RepoRap/Fspec.adl, 
+                AmpersandData/RepoRap/RAP.adl, 
+                AmpersandData/RepoRap/README.txt, 
+                AmpersandData/RepoRap/student_AST_interfaces.adl, 
+                outputTemplates/default.asciidoc, 
+                outputTemplates/default.context, 
+                outputTemplates/default.docbook, 
+                outputTemplates/default.html, 
+                outputTemplates/default.latex, 
+                outputTemplates/default.man, 
+                outputTemplates/default.markdown, 
+                outputTemplates/default.mediawiki, 
+                outputTemplates/default.opendocument, 
+                outputTemplates/default.org, 
+                outputTemplates/default.plain, 
+                outputTemplates/default.rst, 
+                outputTemplates/default.rtf, 
+                outputTemplates/default.s5, 
+                outputTemplates/default.slidy, 
+                outputTemplates/default.texinfo, 
+                outputTemplates/default.textile
+
+source-repository head
+  type:      svn
+  location:  https://svn.code.sf.net/p/ampersand/code/trunk
+
+flag executable
+  description:  Build the ampersand executable.
+  default:      True
+
+flag library
+  description:  Build the ampersand library.
+  default:      True
+
+library
+  hs-source-dirs:    src/lib
+  build-depends:    graphviz >= 2999.16.0.0 && <= 2999.17,
+                    base >= 4.5.0.0 && < 5,
+                    containers >= 0.5,
+                    utf8-string >= 0.3.7 && < 0.4,
+                    bytestring >= 0.9.2.1,
+                    filepath >= 1.3.0.0 && < 1.4,
+                    pandoc-types >=1.12.3 && <1.13,
+                    pandoc >= 1.12.1 && < 1.13,
+                    mtl >= 2.1.1 && < 2.2,
+                    directory == 1.2.0.1,
+                    hashable >= 1.2 && < 1.3,
+                    time == 1.4.0.1,
+                    SpreadsheetML >= 0.1 && < 0.2,
+                    process >= 1.1.0.1 && < 1.2,
+                    split >= 0.1 && < 0.2,
+                    old-locale >= 1.0.0.4 && < 1.1
+  exposed-modules:  DatabaseDesign.Ampersand
+  other-modules:    
+                    DatabaseDesign.Ampersand.ADL1,
+                    DatabaseDesign.Ampersand.ADL1.Disambiguate,
+                    DatabaseDesign.Ampersand.ADL1.ECArule,
+                    DatabaseDesign.Ampersand.ADL1.Expression,
+                    DatabaseDesign.Ampersand.ADL1.Lattices,
+                    DatabaseDesign.Ampersand.ADL1.P2A_Converters,
+                    DatabaseDesign.Ampersand.ADL1.Pair,
+                    DatabaseDesign.Ampersand.ADL1.Rule,
+                    DatabaseDesign.Ampersand.Basics,
+                    DatabaseDesign.Ampersand.Basics.Auxiliaries,
+                    DatabaseDesign.Ampersand.Basics.BuildInfo_Generated,
+                    DatabaseDesign.Ampersand.Basics.Collection,
+                    DatabaseDesign.Ampersand.Basics.String,
+                    DatabaseDesign.Ampersand.Basics.UTF8,
+                    DatabaseDesign.Ampersand.Basics.Version,
+                    DatabaseDesign.Ampersand.Classes,
+                    DatabaseDesign.Ampersand.Classes.ConceptStructure,
+                    DatabaseDesign.Ampersand.Classes.Object,
+                    DatabaseDesign.Ampersand.Classes.Populated,
+                    DatabaseDesign.Ampersand.Classes.Relational,
+                    DatabaseDesign.Ampersand.Classes.ViewPoint,
+                    DatabaseDesign.Ampersand.Components,
+                    DatabaseDesign.Ampersand.Core.AbstractSyntaxTree,
+                    DatabaseDesign.Ampersand.Core.ParseTree,
+                    DatabaseDesign.Ampersand.Core.Poset,
+                    DatabaseDesign.Ampersand.Core.Poset.Instances,
+                    DatabaseDesign.Ampersand.Core.Poset.Internal,
+                    DatabaseDesign.Ampersand.Fspec,
+                    DatabaseDesign.Ampersand.Fspec.FPA,
+                    DatabaseDesign.Ampersand.Fspec.Fspec,
+                    DatabaseDesign.Ampersand.Fspec.GenerateUML,
+                    DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram,
+                    DatabaseDesign.Ampersand.Fspec.Graphic.Graphics,
+                    DatabaseDesign.Ampersand.Fspec.Graphic.Picture,
+                    DatabaseDesign.Ampersand.Fspec.Motivations,
+                    DatabaseDesign.Ampersand.Fspec.Plug,
+                    DatabaseDesign.Ampersand.Fspec.ShowADL,
+                    DatabaseDesign.Ampersand.Fspec.ShowECA,
+                    DatabaseDesign.Ampersand.Fspec.ShowHS,
+                    DatabaseDesign.Ampersand.Fspec.ShowMeatGrinder,
+                    DatabaseDesign.Ampersand.Fspec.ShowXMLtiny,
+                    DatabaseDesign.Ampersand.Fspec.Switchboard,
+                    DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Fspec,
+                    DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Plug,
+                    DatabaseDesign.Ampersand.Fspec.ToFspec.Calc,
+                    DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms,
+                    DatabaseDesign.Ampersand.Input,
+                    DatabaseDesign.Ampersand.Input.ADL1.CtxError,
+                    DatabaseDesign.Ampersand.Input.ADL1.FilePos,
+                    DatabaseDesign.Ampersand.Input.ADL1.Parser,
+                    DatabaseDesign.Ampersand.Input.ADL1.UU_BinaryTrees,
+                    DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing,
+                    DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner,
+                    DatabaseDesign.Ampersand.Input.Parsing,
+                    DatabaseDesign.Ampersand.InputProcessing,
+                    DatabaseDesign.Ampersand.Misc,
+                    DatabaseDesign.Ampersand.Misc.Explain,
+                    DatabaseDesign.Ampersand.Misc.Languages,
+                    DatabaseDesign.Ampersand.Misc.Options,
+                    DatabaseDesign.Ampersand.Misc.TinyXML,
+                    DatabaseDesign.Ampersand.Output,
+                    DatabaseDesign.Ampersand.Output.Fspec2Excel,
+                    DatabaseDesign.Ampersand.Output.Fspec2Pandoc,
+                    DatabaseDesign.Ampersand.Output.PandocAux,
+                    DatabaseDesign.Ampersand.Output.PredLogic,
+                    DatabaseDesign.Ampersand.Output.Statistics,
+                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterConceptualAnalysis,
+                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDataAnalysis,
+                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDiagnosis,
+                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterECArules,
+                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterGlossary,
+                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterInterfaces,
+                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterIntroduction,
+                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterNatLangReqs,
+                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterProcessAnalysis,
+                    DatabaseDesign.Ampersand.Output.ToPandoc.ChapterSoftwareMetrics,
+                    DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters,
+                    Paths_ampersand
+                    
+  default-language:  Haskell2010
+
+  if flag(library)
+    buildable:  True
+
+  else
+    buildable:  False
+
+executable ampersand
+  main-is:           Main.hs
+  hs-source-dirs:    src/exec
+  build-depends:     ampersand == 3.0.0,
+                     graphviz >= 2999.16.0.0 && <= 2999.17,
+                     filepath >= 1.3.0.0 && < 1.4,
+                     base >= 4.5.0.0
+  default-language:  Haskell2010
+  ghc-options:       -rtsopts
+  --inspired by http://stackoverflow.com/questions/7140732/haskell-space-overflow :
+                     -O2
+  if flag(executable)
+    buildable:  True
+  else
+    buildable:  False
+
+ outputTemplates/default.asciidoc view
@@ -0,0 +1,26 @@+$if(titleblock)$+$title$+$for(author)$+:author: $author$+$endfor$+$if(date)$+:date: $date$+$endif$+$if(toc)$+:toc:+$endif$++$endif$+$for(header-includes)$+$header-includes$++$endfor$+$for(include-before)$+$include-before$++$endfor$+$body$+$for(include-after)$++$include-after$+$endfor$
+ outputTemplates/default.context view
@@ -0,0 +1,84 @@+\enableregime[utf]  % use UTF-8++\setupcolors[state=start]+\setupinteraction[state=start, color=middleblue] % needed for hyperlinks++\setuppapersize[letter][letter]  % use letter paper+\setuplayout[width=middle, backspace=1.5in, cutspace=1.5in,+             height=middle, header=0.75in, footer=0.75in] % page layout+\setuppagenumbering[location={footer,center}]  % number pages+\setupbodyfont[11pt]  % 11pt font+\setupwhitespace[medium]  % inter-paragraph spacing++\setuphead[section][style=\tfc]+\setuphead[subsection][style=\tfb]+\setuphead[subsubsection][style=\bf]++% define descr (for definition lists)+\definedescription[descr][+  headstyle=bold,style=normal,align=left,location=hanging,+  width=broad,margin=1cm]++% prevent orphaned list intros+\setupitemize[autointro]++% define defaults for bulleted lists +\setupitemize[1][symbol=1][indentnext=no]+\setupitemize[2][symbol=2][indentnext=no]+\setupitemize[3][symbol=3][indentnext=no]+\setupitemize[4][symbol=4][indentnext=no]++\setupthinrules[width=15em]  % width of horizontal rules++% for block quotations+\unprotect++\startvariables all+blockquote: blockquote+\stopvariables++\definedelimitedtext+[\v!blockquote][\v!quotation]++\setupdelimitedtext+[\v!blockquote]+[\c!left=,+\c!right=,+before={\blank[medium]},+after={\blank[medium]},+]++\protect+$for(header-includes)$+$header-includes$+$endfor$++\starttext+$if(title)$+\startalignment[center]+  \blank[2*big]+  {\tfd $title$}+$if(author)$+  \blank[3*medium]+  {\tfa $for(author)$$author$$sep$\crlf $endfor$}+$endif$+$if(date)$+  \blank[2*medium]+  {\tfa $date$}+$endif$+  \blank[3*medium]+\stopalignment+$endif$+$for(include-before)$+$include-before$+$endfor$+$if(toc)$+\placecontent+$endif$++$body$++$for(include-after)$+$include-after$+$endfor$+\stoptext
+ outputTemplates/default.docbook view
@@ -0,0 +1,23 @@+<?xml version="1.0" encoding="utf-8" ?>+<!DOCTYPE article PUBLIC "-//OASIS//DTD DocBook XML V4.4//EN"+                  "http://www.oasis-open.org/docbook/xml/4.4/docbookx.dtd">+<article>+  <articleinfo>+    <title>$title$</title>+$for(author)$+    <author>+      $author$+    </author>+$endfor$+$if(date)$+    <date>$date$</date>+$endif$+  </articleinfo>+$for(include-before)$+$include-before$+$endfor$+$body$+$for(include-after)$+$include-after$+$endfor$+</article>
+ outputTemplates/default.html view
@@ -0,0 +1,86 @@+$if(html5)$+<!DOCTYPE html>+<html$if(lang)$ lang="$lang$"$endif$>+$else$+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml"$if(lang)$ lang="$lang$" xml:lang="$lang$"$endif$>+$endif$+<head>+$if(html5)$+  <meta charset="utf-8" />+$else$+  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />+$endif$+  <meta name="generator" content="pandoc" />+$for(author)$+  <meta name="author" content="$author$" />+$endfor$+$if(date)$+  <meta name="date" content="$date$" />+$endif$+  <title>$if(title-prefix)$$title-prefix$ - $endif$$if(pagetitle)$$pagetitle$$endif$</title>+$if(html5)$+  <!--[if lt IE 9]>+    <script src="http://html5shim.googlecode.com/svn/trunk/html5.js"></script>+  <![endif]-->+$endif$+$if(highlighting-css)$+  <style type="text/css">+/*<![CDATA[*/+$highlighting-css$+/*]]>*/+  </style>+$endif$+$for(css)$+  <link rel="stylesheet" href="$css$" $if(html5)$$else$type="text/css" $endif$/>+$endfor$+$if(math)$+$if(html5)$+$else$+  $math$+$endif$+$endif$+$for(header-includes)$+  $header-includes$+$endfor$+</head>+<body>+$for(include-before)$+$include-before$+$endfor$+$if(title)$+$if(html5)$+<header>+$else$+<div id="$idprefix$header">+$endif$+<h1 class="title">$title$</h1>+$for(author)$+<h3 class="author">$author$</h3>+$endfor$+$if(date)$+<h4 class="date">$date$</h4>+$endif$+$if(html5)$+</header>+$else$+</div>+$endif$+$endif$+$if(toc)$+$if(html5)$+<nav id="$idprefix$TOC">+$toc$+</nav>+$else$+<div id="$idprefix$TOC">+$toc$+</div>+$endif$+$endif$+$body$+$for(include-after)$+$include-after$+$endfor$+</body>+</html>
+ outputTemplates/default.latex view
@@ -0,0 +1,174 @@+\documentclass[$if(fontsize)$$fontsize$,$endif$$if(lang)$$lang$,$endif$]{$documentclass$}
+\usepackage[T1]{fontenc}
+\usepackage{lmodern}
+\usepackage{amssymb,amsmath}
+\usepackage{ifxetex,ifluatex}
+\usepackage{fixltx2e} % provides \textsubscript
+% use microtype if available
+\IfFileExists{microtype.sty}{\usepackage{microtype}}{}
+\ifnum 0\ifxetex 1\fi\ifluatex 1\fi=0 % if pdftex
+  \usepackage[utf8]{inputenc}
+$if(euro)$
+  \usepackage{eurosym}
+$endif$
+\else % if luatex or xelatex
+  \usepackage{fontspec}
+  \ifxetex
+    \usepackage{xltxtra,xunicode}
+  \fi
+  \defaultfontfeatures{Mapping=tex-text,Scale=MatchLowercase}
+  \newcommand{\euro}{€}
+$if(mainfont)$
+    \setmainfont{$mainfont$}
+$endif$
+$if(sansfont)$
+    \setsansfont{$sansfont$}
+$endif$
+$if(monofont)$
+    \setmonofont{$monofont$}
+$endif$
+$if(mathfont)$
+    \setmathfont{$mathfont$}
+$endif$
+\fi
+$if(geometry)$
+\usepackage[$for(geometry)$$geometry$$sep$,$endfor$]{geometry}
+$endif$
+$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(fancy-enums)$
+% Redefine labelwidth for lists; otherwise, the enumerate package will cause
+% markers to extend beyond the left margin.
+\makeatletter\AtBeginDocument{%
+  \renewcommand{\@listi}
+    {\setlength{\labelwidth}{4em}}
+}\makeatother
+\usepackage{enumerate}
+$endif$
+$if(tables)$
+\usepackage{ctable}
+\usepackage{float} % provides the H option for float placement
+$endif$
+$if(graphics)$
+\usepackage{graphicx}
+% We will generate all images so they have a width \maxwidth. This means
+% that they will get their normal width if they fit onto the page, but
+% are scaled down if they would overflow the margins.
+\makeatletter
+\def\maxwidth{\ifdim\Gin@nat@width>\linewidth\linewidth
+\else\Gin@nat@width\fi}
+\makeatother
+\let\Oldincludegraphics\includegraphics
+\renewcommand{\includegraphics}[1]{\Oldincludegraphics[width=\maxwidth]{#1}}
+$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,
+            bookmarks=true,
+            pdfauthor={$author-meta$},
+            pdftitle={$title-meta$},
+            colorlinks=true,
+            urlcolor=$if(urlcolor)$$urlcolor$$else$blue$endif$,
+            linkcolor=$if(linkcolor)$$linkcolor$$else$magenta$endif$,
+            pdfborder={0 0 0}}
+$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)$
+$else$
+\setcounter{secnumdepth}{0}
+$endif$
+$if(verbatim-in-note)$
+\VerbatimFootnotes % allows verbatim text in footnotes
+$endif$
+$if(lang)$
+\ifxetex
+  \usepackage{polyglossia}
+  \setmainlanguage{$mainlang$}
+\else
+  \usepackage[$lang$]{babel}
+\fi
+$endif$
+$for(header-includes)$
+$header-includes$
+$endfor$
+
+$if(title)$
+\title{$title$}
+$endif$
+\author{$for(author)$$author$$sep$ \and $endfor$}
+\date{$date$}
+
+\begin{document}
+$if(title)$
+\maketitle
+$endif$
+
+$for(include-before)$
+$include-before$
+
+$endfor$
+$if(toc)$
+{
+\hypersetup{linkcolor=black}
+\tableofcontents
+}
+$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 view
@@ -0,0 +1,18 @@+$if(has-tables)$+.\"t+$endif$+.TH $title$ $section$ "$date$" $description$+$for(header-includes)$+$header-includes$+$endfor$+$for(include-before)$+$include-before$+$endfor$+$body$+$for(include-after)$+$include-after$+$endfor$+$if(author)$+.SH AUTHORS+$for(author)$$author$$sep$; $endfor$.+$endif$
+ outputTemplates/default.markdown view
@@ -0,0 +1,23 @@+$if(titleblock)$+% $title$+% $for(author)$$author$$sep$; $endfor$+% $date$++$endif$+$for(header-includes)$+$header-includes$++$endfor$+$for(include-before)$+$include-before$++$endfor$+$if(toc)$+$toc$++$endif$+$body$+$for(include-after)$++$include-after$+$endfor$
+ outputTemplates/default.mediawiki view
@@ -0,0 +1,13 @@+$for(include-before)$+$include-before$++$endfor$+$if(toc)$+__TOC__++$endif$+$body$+$for(include-after)$++$include-after$+$endfor$
+ outputTemplates/default.opendocument view
@@ -0,0 +1,27 @@+<?xml version="1.0" encoding="utf-8" ?>+<office:document-content xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:xforms="http://www.w3.org/2002/xforms" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" office:version="1.0">+  $automatic-styles$+$for(header-includes)$+  $header-includes$+$endfor$  +<office:body>+<office:text>+$if(title)$+<text:h text:style-name="Heading_20_1" text:outline-level="1">$title$</text:h>+$endif$+$for(author)$+<text:p text:style-name="Author">$author$</text:p>+$endfor$+$if(date)$+<text:p text:style-name="Date">$date$</text:p>+$endif$+$for(include-before)$+$include-before$+$endfor$+$body$+$for(include-after)$+$include-after$+$endfor$+</office:text>+</office:body>+</office:document-content>
+ outputTemplates/default.org view
@@ -0,0 +1,24 @@+$if(title)$+$title$++$endif$+$if(author)$+#+AUTHOR: $for(author)$$author$$sep$; $endfor$+$endif$+$if(date)$+#+DATE: $date$++$endif$+$for(header-includes)$+$header-includes$++$endfor$+$for(include-before)$+$include-before$++$endfor$+$body$+$for(include-after)$++$include-after$+$endfor$
+ outputTemplates/default.plain view
@@ -0,0 +1,23 @@+$if(titleblock)$+$title$+$for(author)$$author$$sep$; $endfor$+$date$++$endif$+$for(header-includes)$+$header-includes$++$endfor$+$for(include-before)$+$include-before$++$endfor$+$if(toc)$+$toc$++$endif$+$body$+$for(include-after)$++$include-after$+$endfor$
+ outputTemplates/default.rst view
@@ -0,0 +1,39 @@+$if(title)$+$title$++$endif$+$for(author)$+:Author: $author$+$endfor$+$if(date)$+:Date:   $date$+$endif$+$if(author)$++$else$+$if(date)$++$endif$+$endif$+$if(math)$+.. role:: math(raw)+   :format: html latex++$endif$+$for(include-before)$+$include-before$++$endfor$+$if(toc)$+.. contents::++$endif$+$for(header-includes)$+$header-includes$++$endfor$+$body$+$for(include-after)$++$include-after$+$endfor$
+ outputTemplates/default.rtf view
@@ -0,0 +1,27 @@+{\rtf1\ansi\deff0{\fonttbl{\f0 \fswiss Helvetica;}{\f1 Courier;}}+{\colortbl;\red255\green0\blue0;\red0\green0\blue255;}+\widowctrl\hyphauto+$for(header-includes)$+$header-includes$+$endfor$++$if(title)$+{\pard \qc \f0 \sa180 \li0 \fi0 \b \fs36 $title$\par}+$endif$+$for(author)$+{\pard \qc \f0 \sa180 \li0 \fi0  $author$\par}+$endfor$+$if(date)$+{\pard \qc \f0 \sa180 \li0 \fi0  $date$\par}+$endif$+$if(spacer)$+{\pard \ql \f0 \sa180 \li0 \fi0 \par}+$endif$+$for(include-before)$+$include-before$+$endfor$+$body$+$for(include-after)$+$include-after$+$endfor$+}
+ outputTemplates/default.s5 view
@@ -0,0 +1,69 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+<head>+  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />+  <meta name="generator" content="pandoc" />+$for(author)$+  <meta name="author" content="$author$" />+$endfor$+$if(date)$+  <meta name="date" content="$date$" />+$endif$+  <title>$if(title-prefix)$$title-prefix$ - $endif$$if(pagetitle)$$pagetitle$$endif$</title>+  <!-- configuration parameters -->+  <meta name="defaultView" content="slideshow" />+  <meta name="controlVis" content="hidden" />+$if(highlighting-css)$+  <style type="text/css">+$highlighting-css$+  </style>+$endif$+$for(css)$+  <link rel="stylesheet" href="$css$" type="text/css" />+$endfor$+$if(s5includes)$+$s5includes$+$else$+  <!-- style sheet links -->+  <link rel="stylesheet" href="$s5-url$/slides.css" type="text/css" media="projection" id="slideProj" />+  <link rel="stylesheet" href="$s5-url$/outline.css" type="text/css" media="screen" id="outlineStyle" />+  <link rel="stylesheet" href="$s5-url$/print.css" type="text/css" media="print" id="slidePrint" />+  <link rel="stylesheet" href="$s5-url$/opera.css" type="text/css" media="projection" id="operaFix" />+  <!-- S5 JS -->+  <script src="$s5-url$/slides.js" type="text/javascript"></script>+$endif$+$if(math)$+  $math$+$endif$+$for(header-includes)$+  $header-includes$+$endfor$+</head>+<body>+$for(include-before)$+$include-before$+$endfor$+<div class="layout">+<div id="controls"></div>+<div id="currentSlide"></div>+<div id="header"></div>+<div id="footer">+  <h1>$date$</h1>+  <h2>$title$</h2>+</div>+</div>+<div class="presentation">+$if(title)$+<div class="slide">+  <h1>$title$</h1>+  <h3>$for(author)$$author$$sep$<br/>$endfor$</h3>+  <h4>$date$</h4>+</div>+$endif$+$body$+$for(include-after)$+$include-after$+$endfor$+</div>+</body>+</html>
+ outputTemplates/default.slidy view
@@ -0,0 +1,76 @@+<?xml version="1.0" encoding="utf-8"?>+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+<html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">+<head>+  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />+  <meta name="generator" content="pandoc" />+$for(author)$+  <meta name="author" content="$author$" />+$endfor$+$if(date)$+  <meta name="date" content="$date$" />+$endif$+$if(highlighting-css)$+  <title>$if(title-prefix)$$title-prefix$ - $endif$$if(pagetitle)$$pagetitle$$endif$</title>+  <style type="text/css">+/*<![CDATA[*/+$highlighting-css$+/*]]>*/+  </style>+$endif$+$if(slidy-css)$+  <style type="text/css">+/*<![CDATA[*/+$slidy-css$+/*]]>*/+  </style>+$else$+  <link rel="stylesheet" type="text/css" media="screen, projection, print"+    href="$slidy-url$/styles/slidy.css" />+$endif$+$for(css)$+  <link rel="stylesheet" type="text/css" media="screen, projection, print"+   href="$css$" />+$endfor$+$if(math)$+  $math$+$endif$+$for(header-includes)$+  $header-includes$+$endfor$+$if(slidy-js)$+<script type="text/javascript" charset="utf-8">+/*<![CDATA[*/+$slidy-js$+/*]]>*/+</script>+$else$+  <script src="$slidy-url$/scripts/slidy.js.gz"+    charset="utf-8" type="text/javascript"></script>+$endif$+$if(duration)$+  <meta name="duration" content="$duration$" />+$endif$+</head>+<body>+$for(include-before)$+$include-before$+$endfor$+$if(title)$+<div class="slide titlepage">+  <h1 class="title">$title$</h1>+  <p class="author">+$for(author)$$author$$sep$<br/>$endfor$+  </p>+$if(date)$+  <p class="date">$date$</p>+$endif$+</div>+$endif$+$body$+$for(include-after)$+$include-after$+$endfor$+</body>+</html>
+ outputTemplates/default.texinfo view
@@ -0,0 +1,64 @@+\input texinfo+@documentencoding utf-8+$for(header-includes)$+$header-includes$+$endfor$++$if(strikeout)$+@macro textstrikeout{text}+~~\text\~~+@end macro++$endif$+$if(subscript)$+@macro textsubscript{text}+@iftex+@textsubscript{\text\}+@end iftex+@ifnottex+_@{\text\@}+@end ifnottex+@end macro++$endif$+$if(superscript)$+@macro textsuperscript{text}+@iftex+@textsuperscript{\text\}+@end iftex+@ifnottex+^@{\text\@}+@end ifnottex+@end macro++$endif$+@ifnottex+@paragraphindent 0+@end ifnottex+$if(titlepage)$+@titlepage+@title $title$+$for(author)$+@author $author$+$endfor$+$if(date)$+$date$+$endif$+@end titlepage++$endif$+$for(include-before)$+$include-before$++$endfor$+$if(toc)$+@contents++$endif$+$body$+$for(include-after)$++$include-after$+$endfor$++@bye
+ outputTemplates/default.textile view
@@ -0,0 +1,9 @@+$for(include-before)$+$include-before$++$endfor$+$body$+$for(include-after)$++$include-after$+$endfor$
+ src/exec/Main.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -Wall #-}+module Main where++import Control.Monad+import System.Exit+import Prelude hiding (readFile,writeFile)+import Data.List (intersperse)+import DatabaseDesign.Ampersand (getOptions, showErr, showVersion, showHelp, helpNVersionTexts, ampersandVersionStr, createFspec, Guarded(..), generateAmpersandOutput)+-- import DatabaseDesign.Ampersand.Misc +-- import qualified DatabaseDesign.Ampersand.Basics as Basics+-- import DatabaseDesign.Ampersand.Components+-- import DatabaseDesign.Ampersand.InputProcessing+-- import DatabaseDesign.Ampersand.Input.ADL1.CtxError (showErr)++main :: IO ()+main =+ do flags <- getOptions+    if showVersion flags || showHelp flags+    then mapM_ putStr (helpNVersionTexts ampersandVersionStr flags)+    else do gFspec <- createFspec flags+            case gFspec of+              Errors err -> do Prelude.putStrLn $ "Error(s) found:"+                               mapM_ putStrLn (intersperse  (replicate 30 '=') (map showErr err))+                               exitWith $ ExitFailure 10+              Checked fspc -> generateAmpersandOutput flags fspc
+ src/lib/DatabaseDesign/Ampersand.hs view
@@ -0,0 +1,113 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand
+   ( -- Data Constructors:
+     A_Context
+   , P_Context(..), P_Population(..), PairView(..), PairViewSegment(..), SrcOrTgt(..), P_Rule(..), Term(..), TermPrim(..), P_Sign(..), P_Concept(..), P_Declaration(..), P_Pattern(..), P_Gen(..)
+   , P_Markup(..), PRef2Obj(..), PPurpose(..), PMeaning(..), RelConceptDef(..)
+   , A_Concept(..), A_Gen(..)
+   , Sign(..), ConceptDef(..), ConceptStructure(..)
+   , Activity(..)
+   , AMeaning(..)
+   , Quad(..), RuleClause(..)
+   , ECArule(..)
+   , Pattern(..)
+   , Declaration(..)
+   , IdentityDef(..)
+   , ViewDef(..)
+   , IdentitySegment(..)
+   , ViewSegment(..)
+   , Expression(..)
+   , Population(..)
+   , Fspc(..)
+   , Fswitchboard(..)
+   , PlugSQL(..), SqlField(..), SqlType(..), PlugInfo(..)
+   , Rule(..)
+   , Process(..) , FProcess(..)
+   , Prop(..), RuleOrigin(..)
+   , Lang(..)
+   , SqlFieldUsage(..)
+   , DnfClause(..), Clauses(..)
+   , Options(..), DocTheme(..)
+   , Picture(..), writePicture, DrawingType(..)
+   , FilePos(..), Origin(..), Pos(Pos)
+   , FPA(..), FPcompl(..)
+   , mkPair
+   -- * Classes:
+   , Association(..), flp
+   , Collection(..)
+   , Identified(..)
+   , ProcessStructure(..)
+   , ObjectDef(..)
+   , Relational(..)
+   , objAts, objatsLegacy
+   , Interface(..)
+   , SubInterface(..)
+   , Object(..)
+   , Plugable(..)
+   , Motivated(..)
+   , Traced(..)
+   , Language(..)
+   , Dotable(..)
+   , FPAble(..)
+   , ShowHS(..), ShowHSName(..), haskellIdentifier
+   -- * Functions on concepts
+   , (<==>),meet,join,sortWith,atomsOf
+   , smallerConcepts, largerConcepts, rootConcepts
+   -- * Functions on declarations
+   , decusr
+   -- * Functions on rules
+   -- * Functions on expressions:
+   , conjNF, disjNF, simplify
+   , cfProof,dfProof,nfProof,normPA
+   , lookupCpt
+   , showPrf
+   , notCpl, isCpl, isPos, isNeg
+      , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.:.), (.!.), (.*.)
+   , deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc
+   , exprUni2list, exprIsc2list, exprCps2list, exprRad2list
+   -- * Functions with plugs:
+   , plugFields, tblcontents, plugpath, fldauto, requires, requiredFields, isPlugIndex
+   -- * Parser related stuff
+   , parseADL1pExpr, CtxError 
+   , createFspec
+   , getGeneralizations, getSpecializations
+    -- * Type checking and calculus
+   , Guarded(..), pCtx2aCtx
+   , makeFspec
+    -- * Generators of output
+   , generateAmpersandOutput
+   -- * Prettyprinters
+   , ShowADL(..), showSQL, showSign
+   -- * Functions with Options
+   , getOptions
+   , verboseLn, verbose
+   , FileFormat(..),helpNVersionTexts
+   -- * Other functions
+   , eqCl, showErr, unCap,upCap,escapeNonAlphaNum, fatalMsg
+   , ampersandVersionStr, ampersandVersionWithoutBuildTimeStr
+   , DatabaseDesign.Ampersand.Basics.putStr
+   , DatabaseDesign.Ampersand.Basics.hGetContents
+   , DatabaseDesign.Ampersand.Basics.hPutStr
+   , DatabaseDesign.Ampersand.Basics.hPutStrLn
+   , DatabaseDesign.Ampersand.Basics.readFile
+   , DatabaseDesign.Ampersand.Basics.writeFile
+   -- * Stuff that should probably not be in the prototype
+   , A_Markup(..), blocks2String, aMarkup2String, PandocFormat(..), Meaning(..)
+   , rulefromProp
+   , Populated(..), Paire, Purpose(..), ExplObj(..), PictType(..)
+   )
+where
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+import DatabaseDesign.Ampersand.Fspec.Fspec
+import DatabaseDesign.Ampersand.Fspec.FPA
+import DatabaseDesign.Ampersand.ADL1 
+import DatabaseDesign.Ampersand.Classes
+import DatabaseDesign.Ampersand.Basics 
+import DatabaseDesign.Ampersand.Fspec
+import DatabaseDesign.Ampersand.Input
+import DatabaseDesign.Ampersand.Misc
+import DatabaseDesign.Ampersand.Components 
+import DatabaseDesign.Ampersand.ADL1.Expression (isPos,isNeg)
+import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms
+import DatabaseDesign.Ampersand.InputProcessing
+import DatabaseDesign.Ampersand.ADL1.P2A_Converters
+ src/lib/DatabaseDesign/Ampersand/ADL1.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.ADL1 (module X) 
+where
+import DatabaseDesign.Ampersand.Core.ParseTree as X (
+           PPurpose(..), PRef2Obj(..)
+         , Paire, Pairs, mkPair , srcPaire, trgPaire
+         , Label(..)
+         , FilePos(..), Origin(..), Pos(..), Traced(..)
+         , Prop(..)
+         , P_Concept(..)
+         , P_Sign(..)
+         , P_Context(..)
+         , Meta(..)
+         , MetaObj(..)
+         , P_Process(..), P_RoleRelation(..), RoleRule(..)
+         , P_Pattern(..)
+         , PairView(..), PairViewSegment(..)
+         , SrcOrTgt(..)
+         , P_Rule(..)
+         , P_IdentDef(..), P_IdentSegment(..)
+         , P_ViewDef, P_ViewSegment
+         , P_Population(..)
+         , P_ObjectDef
+         , P_Interface(..)
+         , P_SubInterface
+         , Term(..)
+         , TermPrim(..)
+         , P_Gen(..)
+         , P_Declaration(..)
+         , ConceptDef(..)
+         , gen_concs
+         )
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree as X  (
+          A_Concept(..)
+         ,Sign(..),showSign,GenR()
+         , (<==>),meet,join
+         ,Signaling(..)
+         ,A_Context(..),Process(..)
+         ,Association(..)
+         ,Expression(..)
+         ,A_Gen(..)
+         ,IdentityDef(..)
+         ,IdentitySegment(..)
+         ,ViewDef(..)
+         ,ViewSegment(..)
+         ,ObjectDef(..)
+         ,objAts
+         ,objatsLegacy
+         ,SubInterface(..)
+         ,Declaration(..),decusr
+         ,Interface(..)
+         ,Pattern(..)
+         ,Rule(..)
+         ,RuleType(..)
+         ,RoleRelation(..)
+         ,Population(..)
+         ,Purpose(..), ExplObj(..)
+         , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.:.), (.!.), (.*.)
+         )
+import DatabaseDesign.Ampersand.ADL1.Expression as X (
+         notCpl, isCpl, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc)
+import DatabaseDesign.Ampersand.ADL1.ECArule as X (
+         isAll, isCHC, isBlk, isNop, isDo, dos)
+import DatabaseDesign.Ampersand.ADL1.Rule as X (
+          rulefromProp, ruleviolations
+         ,consequent,antecedent,hasantecedent)
+ src/lib/DatabaseDesign/Ampersand/ADL1/Disambiguate.hs view
@@ -0,0 +1,220 @@+{-# OPTIONS_GHC -Wall -XFlexibleInstances -XDataKinds #-}+{-# LANGUAGE RelaxedPolyRec #-}+module DatabaseDesign.Ampersand.ADL1.Disambiguate(disambiguate, gc, DisambPrim(..), findConceptOrONE, findConcept, pCpt2aCpt) where+import DatabaseDesign.Ampersand.Core.ParseTree+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (sortWith, maxima, greatest)+import DatabaseDesign.Ampersand.Basics (Identified(name), fatalMsg)+import Prelude hiding (head, sequence, mapM)+import Control.Applicative+import Data.Traversable+import qualified Data.Set as Set++disambiguate :: (Traversable d, Disambiguatable d) =>+                (a -> (TermPrim, DisambPrim)) -- disambiguation function+                -> d a -- object to be disambiguated+                -> d (TermPrim, DisambPrim) -- disambiguated object+disambiguate termPrimDisAmb x = fixpoint disambiguationStep (Change (fmap termPrimDisAmb x) False)++fatal :: Int -> String -> a+fatal = fatalMsg "ADL1.Disambiguate"++findConceptOrONE :: String -> A_Concept+findConceptOrONE "ONE" = ONE+findConceptOrONE x = findConcept x++-- TODO: Can we use Uniplate in place of disambiguatable?++findConcept :: String -> A_Concept+-- SJC: ONE should be tokenized, so it cannot occur as a string+-- especially because we require that concepts are identifiable by their name+-- hence if this line would change the semantics, we have either+-- (1) made a programming error in the call of findConcept (in which case you should call findConceptOrONE instead)+-- (2) made an error in the tokenizer/parser+findConcept "ONE" = fatal 200 "ONE is not a valid name for a concept"+findConcept x = PlainConcept +            {cptnm = x+            ,cpttp = [] -- fatal 588 "Types of concepts are not defined here"+            ,cptdf = [] -- fatal 589 "df of concepts are not defined here"+            }++class Disambiguatable d where+  disambInfo :: d (TermPrim,DisambPrim)+   -> ( [(DisambPrim,SrcOrTgt)], [(DisambPrim,SrcOrTgt)] ) -- the inferred types (from the environment = top down)+   -> ( d ((TermPrim,DisambPrim), ([(DisambPrim,SrcOrTgt)],[(DisambPrim,SrcOrTgt)])) -- only the environment for the term (top down)+      , ( [(DisambPrim,SrcOrTgt)], [(DisambPrim,SrcOrTgt)] ) -- the inferred type, bottom up (not including the environment, that is: not using the second argument: prevent loops!)+      )++instance Disambiguatable P_Rule where+  disambInfo (P_Ru nm expr fps mean msg Nothing) x+   = (P_Ru nm exp' fps mean msg Nothing, rt)+   where (exp',rt) = disambInfo expr x+  disambInfo (P_Ru nm expr fps mean msg (Just viol)) x+   = (P_Ru nm exp' fps mean msg (Just viol'), rt)+   where (exp',rt) = disambInfo expr x+         (PairViewTerm viol',_) -- SJ 20131123: disambiguation does not depend on the contents of this pairview, but must come from outside...+          = (disambInfo (PairViewTerm viol) rt)+instance Disambiguatable PairViewTerm where+  disambInfo (PairViewTerm (PairView lst)) x+   = (PairViewTerm (PairView [pv' | pv <- lst, let (PairViewSegmentTerm pv',_) = disambInfo (PairViewSegmentTerm pv) x])+     , ([],[])) -- unrelated+instance Disambiguatable PairViewSegmentTerm where+  disambInfo (PairViewSegmentTerm (PairViewText s)) _ = (PairViewSegmentTerm (PairViewText s), ([],[]))+  disambInfo (PairViewSegmentTerm (PairViewExp st a)) (sr,tg) = (PairViewSegmentTerm (PairViewExp st res), rt)+    where t = case st of+               Src -> sr+               Tgt -> tg+          (res,rt) = disambInfo a (t,[])+instance Disambiguatable P_ViewD where+  disambInfo (P_Vd { vd_pos = o+                   , vd_lbl = s+                   , vd_cpt = c+                   , vd_ats = a+                   }) _ = (P_Vd o s c (map (\x -> fst (disambInfo x (c',[]))) a), (c',[]))+   where c' = [(Known (EDcI (pCpt2aCpt c)),Src)]++instance Disambiguatable P_ViewSegmt where+  disambInfo (P_ViewText a) _ = (P_ViewText a,([],[]))+  disambInfo (P_ViewHtml a) _ = (P_ViewHtml a,([],[]))+  disambInfo (P_ViewExp a) i = (P_ViewExp a',r)+    where (a',r) = disambInfo a i++instance Disambiguatable P_SubIfc where+  disambInfo (P_InterfaceRef a b) _   = (P_InterfaceRef a b,([],[]))+  disambInfo (P_Box o []   ) _        = (P_Box o [],([],[]))+  disambInfo (P_Box o (a:lst)) (x,_)  = (P_Box o (a':lst'),(r++nxt,[]))+   where (a', (r,_))            = disambInfo a (nxt++x,[])+         (P_Box _ lst',(nxt,_)) = disambInfo (P_Box o lst) (x++r,[])++instance Disambiguatable P_ObjDef where+  disambInfo (P_Obj a b c -- term/expression+                        d -- (potential) subobject+                        f)+                        (r,_) -- from the environment, only the source is important+   = (P_Obj a b c' d' f, (r0,[]) -- only source information should be relevant+     )+    where+     (d', (r1,_))+      = case d of+           Nothing -> (Nothing,([],[]))+           Just si -> (\(x,y)->(Just x,y)) $ disambInfo si (r2,[])+     (c', (r0,r2))+      = disambInfo c (r,r1)+instance Disambiguatable Term where+  disambInfo (PFlp o a  ) (ia1,ib1) = ( PFlp o a', (ib2,ia2) )+   where (a', (ia2,ib2)) = disambInfo a (ib1, ia1)+  disambInfo (PCpl o a  ) (ia1,ib1) = ( PCpl o a', (ia2,ib2) )+   where (a', (ia2,ib2)) = disambInfo a (ia1, ib1)+  disambInfo (PBrk o a  ) (ia1,ib1) = ( PBrk o a', (ia2,ib2) )+   where (a', (ia2,ib2)) = disambInfo a (ia1, ib1)+  disambInfo (PKl0 o a  ) (ia1,ib1) = ( PKl0 o a', (ia2++ib2,ia2++ib2) )+   where (a', (ia2,ib2)) = disambInfo a (ia1++ib1, ia1++ib1)+  disambInfo (PKl1 o a  ) (ia1,ib1) = ( PKl1 o a', (ia2++ib2,ia2++ib2) )+   where (a', (ia2,ib2)) = disambInfo a (ia1++ib1, ia1++ib1)+  disambInfo (Pequ o a b) (ia1,ib1) = ( Pequ o a' b', (ia2++ia3, ib2++ib3) )+   where (a', (ia2,ib2)) = disambInfo a (ia1++ia3, ib1++ib3)+         (b', (ia3,ib3)) = disambInfo b (ia1++ia2, ib1++ib2)+  disambInfo (Pimp o a b) (ia1,ib1) = ( Pimp o a' b', (ia2++ia3, ib2++ib3) )+   where (a', (ia2,ib2)) = disambInfo a (ia1++ia3, ib1++ib3)+         (b', (ia3,ib3)) = disambInfo b (ia1++ia2, ib1++ib2)+  disambInfo (PIsc o a b) (ia1,ib1) = ( PIsc o a' b', (ia2++ia3, ib2++ib3) )+   where (a', (ia2,ib2)) = disambInfo a (ia1++ia3, ib1++ib3)+         (b', (ia3,ib3)) = disambInfo b (ia1++ia2, ib1++ib2)+  disambInfo (PUni o a b) (ia1,ib1) = ( PUni o a' b', (ia2++ia3, ib2++ib3) )+   where (a', (ia2,ib2)) = disambInfo a (ia1++ia3, ib1++ib3)+         (b', (ia3,ib3)) = disambInfo b (ia1++ia2, ib1++ib2)+  disambInfo (PDif o a b) (ia1,ib1) = ( PDif o a' b', (ia2++ia3, ib2++ib3) )+   where (a', (ia2,ib2)) = disambInfo a (ia1++ia3, ib1++ib3)+         (b', (ia3,ib3)) = disambInfo b (ia1++ia2, ib1++ib2)+  disambInfo (PLrs o a b) (ia1,ib1) = ( PLrs o a' b', (ia, ib) )+   where (a', (ia,ic1)) = disambInfo a (ia1,ic2)+         (b', (ib,ic2)) = disambInfo b (ib1,ic1)+  disambInfo (PRrs o a b) (ia1,ib1) = ( PRrs o a' b', (ia, ib) )+   where (a', (ic1,ia)) = disambInfo a (ic2,ia1)+         (b', (ic2,ib)) = disambInfo b (ic1,ib1)+  disambInfo (PCps o a b) (ia1,ib1) = ( PCps o a' b', (ia, ib) )+   where (a', (ia,ic1)) = disambInfo a (ia1,ic2)+         (b', (ic2,ib)) = disambInfo b (ic1,ib1)+  disambInfo (PRad o a b) (ia1,ib1) = ( PRad o a' b', (ia, ib) )+   where (a', (ia,ic1)) = disambInfo a (ia1,ic2)+         (b', (ic2,ib)) = disambInfo b (ic1,ib1)+  disambInfo (PPrd o a b) (ia1,ib1) = ( PPrd o a' b', (ia, ib) )+   where (a', (ia,ic1)) = disambInfo a (ia1,ic2)+         (b', (ic2,ib)) = disambInfo b (ic1,ib1)+  disambInfo (Prim (a,b)) st = (Prim ((a,b), st), ([(b,Src)], [(b,Tgt)]) )++data DisambPrim+ = Rel [Expression]+ | Ident+ | Vee+ | Mp1 String+ | Known Expression++-- get concept:+gc :: Association expr => SrcOrTgt -> expr -> String+gc Src e = name (source e)+gc Tgt e = name (target e)++disambiguationStep :: (Disambiguatable d, Traversable d) => d (TermPrim, DisambPrim) -> Change (d (TermPrim, DisambPrim))+disambiguationStep x = traverse performUpdate withInfo+ where (withInfo, _) = disambInfo x ([],[])++performUpdate :: ((t, DisambPrim),+                     ([(DisambPrim, SrcOrTgt)], [(DisambPrim, SrcOrTgt)]))+                     -> Change (t, DisambPrim)+performUpdate ((t,unkn), (srcs',tgts'))+ = case unkn of+     Known _ -> pure (t,unkn)+     Rel xs  -> determineBySize (\x -> if length x == length xs then pure (Rel xs) else impure (Rel x))+                ((findMatch' (mustBeSrc,mustBeTgt) xs `orWhenEmpty` findMatch' (mayBeSrc,mayBeTgt) xs)+                 `orWhenEmpty` xs)+     Ident   -> determineBySize suggest (map (\a -> EDcI (findConceptOrONE a)) (Set.toList possibleConcs))+     Mp1 s   -> determineBySize suggest (map (\a -> EMp1 s (findConceptOrONE a)) (Set.toList possibleConcs))+     Vee     -> determineBySize (const (pure unkn))+                  [EDcV (Sign (findConceptOrONE a) (findConceptOrONE b)) | a<-Set.toList mustBeSrc, b<-Set.toList mustBeTgt]+ where+   suggest [] = pure unkn+   suggest lst = impure (Rel lst) -- TODO: find out whether it is equivalent to put "pure" here (which could be faster).+   possibleConcs = (mustBeSrc `isc` mustBeTgt) `orWhenEmptyS`+                   (mustBeSrc `uni` mustBeTgt) `orWhenEmptyS`+                   (mayBeSrc  `isc` mayBeTgt ) `orWhenEmptyS`+                   (mayBeSrc  `uni` mayBeTgt )+   findMatch' (a,b) = findMatch (Set.toList a,Set.toList b)+   findMatch ([],[]) _ = []+   findMatch ([],tgts) lst+    = [x | x<-lst, gc Tgt x `elem` tgts]+   findMatch (srcs,[]) lst+    = [x | x<-lst, gc Src x `elem` srcs]+   findMatch (srcs,tgts) lst+    = [x | x<-lst, gc Src x `elem` srcs, gc Tgt x `elem` tgts]+   mustBeSrc = mustBe srcs'+   mustBeTgt = mustBe tgts'+   mayBeSrc = mayBe srcs'+   mayBeTgt = mayBe tgts'+   mustBe xs = Set.fromList [gc sot x | (Known x, sot) <- xs]+   mayBe  xs = Set.fromList [gc sot x | (Rel x' , sot) <- xs, x<-x']+   orWhenEmptyS a b = if (Set.null a) then b else a+   orWhenEmpty a b = if (null a) then b else a+   determineBySize _   [a] = impure (t,Known a)+   determineBySize err lst = fmap ((,) t) (err lst)+   impure x = Change x False+   isc = Set.intersection+   uni = Set.union++pCpt2aCpt :: P_Concept -> A_Concept+pCpt2aCpt pc+    = case pc of+        PCpt{} -> findConcept (p_cptnm pc)+        P_Singleton -> ONE   ++data Change a = Change a Bool+instance Functor Change where+ fmap f (Change a b) = Change (f a) b+instance Applicative Change where+ (<*>) (Change f b) (Change a b2) = Change (f a) (b && b2)+ pure a = Change a True++fixpoint :: (a -> Change a) -- function for computing a fixpoint+         -> (Change a) -- has the fixpoint been reached?+         -> a+fixpoint _ (Change a True)  = a+fixpoint f (Change a False) = fixpoint f (f a)
+ src/lib/DatabaseDesign/Ampersand/ADL1/ECArule.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.ADL1.ECArule ( isAll
+                                             , isCHC
+                                             , isBlk
+                                             , isNop
+                                             , isDo
+                                             , dos
+ 
+                                             )
+where
+import DatabaseDesign.Ampersand.Fspec.Fspec
+import DatabaseDesign.Ampersand.Basics     (fatalMsg)
+
+  --   Ampersand derives the process logic from the static logic by interpreting an expression in relation algebra as an invariant.
+  --   So how does Ampersand derive dynamic behaviour from static rules? An example may clarify this:
+  --   Suppose you have large shoes that do not fit through your trousers in any way.
+  --   Does this have any consequences for the process of dressing in the morning?
+  --   Well sure it has!
+  --   Since your shoes won't fit through your trousers, you must first put on your trousers, and then put on your shoes.
+  --   So the order of putting on trousers and putting on shoes is dictated by the (static) fact that your shoes are too big to fit through your trousers.
+  --   When undressing, the order is reversed: you must take off your shoes before taking off your trousers.
+  --   This example ilustrates how the order of activities is restricted by an invariant property.
+  --   So it is possible to derive some dynamic behaviour from static properties.
+  --   The following datatypes form a process algebra.
+fatal :: Int -> String -> a
+fatal = fatalMsg "ADL1.ECArule"
+
+  
+
+isAll :: PAclause -> Bool
+isAll ALL{} = True
+isAll _     = False
+  
+isCHC :: PAclause -> Bool
+isCHC CHC{} = True
+isCHC _     = False
+  
+isBlk :: PAclause -> Bool
+isBlk Blk{} = True
+isBlk _     = False
+  
+isNop :: PAclause -> Bool
+isNop Nop{} = True
+isNop _     = False
+  
+isDo :: PAclause -> Bool
+isDo Do{}   = True
+isDo _      = False
+
+dos :: PAclause -> [PAclause]   -- gather all Do's from a PAclause
+dos p@CHC{} = concatMap dos (paCls p)
+dos p@ALL{} = concatMap dos (paCls p)
+dos p@Do{}  = [p]
+dos p@Sel{} = dos (paCl p "x")
+dos p@New{} = dos (paCl p "x")
+dos p@Rmv{} = dos (paCl p "x")
+dos Nop{}   = []
+dos Blk{}   = []
+dos Let{}   = fatal 56 "dos not defined for `Let` constructor of PAclause"
+dos Ref{}   = fatal 57 "dos not defined for `Ref` constructor of PAclause"
+ 
+
+
+
+ src/lib/DatabaseDesign/Ampersand/ADL1/Expression.hs view
@@ -0,0 +1,135 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE TypeSynonymInstances , OverlappingInstances #-}
+module DatabaseDesign.Ampersand.ADL1.Expression (
+                       subst
+                      ,foldlMapExpression,foldrMapExpression
+                      ,primitives,isMp1
+                      ,isPos,isNeg, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc, notCpl, isCpl)
+where
+import DatabaseDesign.Ampersand.Basics (uni)
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+
+-- fatal :: Int -> String -> a
+-- fatal = fatalMsg "ADL1.Expression"
+
+-- | subst is used to replace each occurrence of a relation
+--   with an expression. The parameter expr will therefore be applied to an
+--   expression of the form Erel rel.
+subst :: (Declaration,Expression) -> Expression -> Expression
+subst (decl,expr) = subs
+     where
+       subs (EEqu (l,r)) = EEqu (subs l,subs r)
+       subs (EImp (l,r)) = EImp (subs l,subs r)
+       subs (EIsc (l,r)) = EIsc (subs l,subs r)
+       subs (EUni (l,r)) = EUni (subs l,subs r)
+       subs (EDif (l,r)) = EDif (subs l,subs r)
+       subs (ELrs (l,r)) = ELrs (subs l,subs r)
+       subs (ERrs (l,r)) = ERrs (subs l,subs r)
+       subs (ECps (l,r)) = ECps (subs l,subs r)
+       subs (ERad (l,r)) = ERad (subs l,subs r)
+       subs (EPrd (l,r)) = EPrd (subs l,subs r)
+       subs (EKl0 e    ) = EKl0 (subs e)
+       subs (EKl1 e    ) = EKl1 (subs e)
+       subs (EFlp e    ) = EFlp (subs e)
+       subs (ECpl e    ) = ECpl (subs e)
+       subs (EBrk e)     = EBrk (subs e)
+       subs e@(EDcD d  ) | d==decl   = expr
+                         | otherwise = e
+       subs e@EDcI{}     = e
+       subs e@EEps{}     = e
+       subs e@EDcV{}     = e
+       subs e@EMp1{}     = e
+
+foldlMapExpression :: (a -> r -> a) -> (Declaration->r) -> a -> Expression -> a
+foldlMapExpression f = foldrMapExpression f' where f' x y = f y x
+
+foldrMapExpression :: (r -> a -> a) -> (Declaration->r) -> a -> Expression -> a
+foldrMapExpression f g a (EEqu (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EImp (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EIsc (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EUni (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EDif (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (ELrs (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (ERrs (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (ECps (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (ERad (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EPrd (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
+foldrMapExpression f g a (EKl0 e)     = foldrMapExpression f g a                         e
+foldrMapExpression f g a (EKl1 e)     = foldrMapExpression f g a                         e
+foldrMapExpression f g a (EFlp e)     = foldrMapExpression f g a                         e
+foldrMapExpression f g a (ECpl e)     = foldrMapExpression f g a                         e
+foldrMapExpression f g a (EBrk e)     = foldrMapExpression f g a                         e
+foldrMapExpression f g a (EDcD d)     = f (g d) a
+foldrMapExpression _ _ a  EDcI{}      = a
+foldrMapExpression _ _ a  EEps{}      = a
+foldrMapExpression _ _ a  EDcV{}      = a
+foldrMapExpression _ _ a  EMp1{}      = a
+
+primitives :: Expression -> [Expression]
+primitives expr =
+  case expr of
+    (EEqu (l,r)) -> primitives l `uni` primitives r
+    (EImp (l,r)) -> primitives l `uni` primitives r
+    (EIsc (l,r)) -> primitives l `uni` primitives r
+    (EUni (l,r)) -> primitives l `uni` primitives r
+    (EDif (l,r)) -> primitives l `uni` primitives r
+    (ELrs (l,r)) -> primitives l `uni` primitives r
+    (ERrs (l,r)) -> primitives l `uni` primitives r
+    (ECps (l,r)) -> primitives l `uni` primitives r
+    (ERad (l,r)) -> primitives l `uni` primitives r
+    (EPrd (l,r)) -> primitives l `uni` primitives r
+    (EKl0 e)     -> primitives e
+    (EKl1 e)     -> primitives e
+    (EFlp e)     -> primitives e
+    (ECpl e)     -> primitives e
+    (EBrk e)     -> primitives e
+    EDcD{}       -> [expr]
+    EDcI{}       -> [expr]
+    EEps{}       -> []  -- Since EEps is inserted for typing reasons only, we do not consider it a primitive..
+    EDcV{}       -> [expr]
+    EMp1{}       -> [expr]
+
+-- | The rule of De Morgan requires care with respect to the complement.
+--   The following function provides a function to manipulate with De Morgan correctly.
+deMorganERad :: Expression -> Expression
+deMorganERad (ECpl (ERad (l,r)))
+  = notCpl (deMorganERad l) .:. notCpl (deMorganERad r)
+deMorganERad (ERad (l,r))
+  = notCpl (notCpl (deMorganERad l) .:. notCpl (deMorganERad r))
+deMorganERad e = e
+deMorganECps :: Expression -> Expression
+deMorganECps (ECpl (ECps (l,r)))
+  = notCpl (deMorganECps l) .!. notCpl (deMorganECps r)
+deMorganECps (ECps (l,r))
+  = notCpl (notCpl (deMorganECps l) .!. notCpl (deMorganECps r))
+deMorganECps e = e
+deMorganEUni :: Expression -> Expression
+deMorganEUni (ECpl (EUni (l,r)))
+  = notCpl (deMorganEUni l) ./\. notCpl (deMorganEUni r)
+deMorganEUni (EUni (l,r))
+  = notCpl (notCpl (deMorganEUni l) ./\. notCpl (deMorganEUni r))
+deMorganEUni e = e
+deMorganEIsc :: Expression -> Expression
+deMorganEIsc (ECpl (EIsc (l,r)))
+  = notCpl (deMorganEIsc l) .\/. notCpl (deMorganEIsc r)
+deMorganEIsc (EIsc (l,r))
+  = notCpl (notCpl (deMorganEIsc l) .\/. notCpl (deMorganEIsc r))
+deMorganEIsc e = e
+
+notCpl :: Expression -> Expression
+notCpl (ECpl e) = e
+notCpl e = ECpl e
+
+isCpl :: Expression -> Bool
+isCpl (ECpl{}) = True
+isCpl _ = False
+
+isPos :: Expression -> Bool
+isPos (ECpl{}) = False
+isPos _ = True
+isNeg :: Expression -> Bool
+isNeg = not . isPos 
+
+isMp1 :: Expression -> Bool
+isMp1 EMp1{} = True
+isMp1 _ = False
+ src/lib/DatabaseDesign/Ampersand/ADL1/Lattices.hs view
@@ -0,0 +1,297 @@+{-# OPTIONS_GHC -Wall -XFlexibleInstances #-}+module DatabaseDesign.Ampersand.ADL1.Lattices (findExact,findSubsets,optimize1,Op1EqualitySystem,addEquality,emptySystem,FreeLattice(..),getGroups,isInSystem) where+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.IntSet as IntSet+import Data.List (sort, partition)++-- optimisations possible for the EqualitySystem(s):+-- (1) apply optimize1 inline, that is: don't use EqualitySystem but use ES1 instead+-- (2) include the transitively dependent rules recursively+data EqualitySystem a+ = ES (Map.Map a Int) -- whatever this is a system of+      (IntMap.IntMap  -- map for: whenever you encounter this element i in your set y+         [( IntSet.IntSet -- when you find this set (that is: if it is a subset of y)+          , IntSet.IntSet -- add this set+          )]+      )++emptySystem :: EqualitySystem a+emptySystem = ES Map.empty IntMap.empty++isInSystem :: (Ord a) => Op1EqualitySystem a -> a -> Bool+isInSystem (ES1 t _ _) a = Map.member a t++-- | getGroups: create groups of concepts (type variable: concept).+--   1. Each concept is in precisely one group.+--   2. Two concepts are in the same group if there is a path of classify-rules between those concepts.+--   The purpose of this is to know whether two concepts are comparable or not. Atoms of concepts within a group can be compared.+--   Atoms of concepts in different groups may never be compared.+getGroups :: (Ord concept, SetLike set) => Op1EqualitySystem concept -> [set concept]+getGroups (ES1 tran _ imap)+ = [fromList [a | (a,i) <- Map.toList tran, not . IntSet.null $ IntSet.intersection i r] | r <- IntMap.elems res]+ where+   iml :: [(Int,[(IntSet.IntSet,IntSet.IntSet)])]+   iml = IntMap.toList imap+   (_, _, res) = foldr getLists (0, IntMap.empty, IntMap.empty) ([(IntSet.insert a (IntSet.union b c)) | (a,bc) <- iml, (b,c)<-bc] ++ Map.elems tran)+   getLists :: IntSet.IntSet -> (Int, IntMap.IntMap Int, IntMap.IntMap (IntSet.IntSet)) -> (Int, IntMap.IntMap Int, IntMap.IntMap (IntSet.IntSet))+   getLists im (acc, allElems, rev) -- TODO: this might be made more efficiently by using Array as the last element+    = if not (IntMap.null overlap) then+       (acc, newElems, newRev)+      else (acc+1, IntMap.union (IntMap.fromSet (const acc) im) allElems, IntMap.insert acc im rev)+    where+      overlap = IntMap.intersection allElems (IntMap.fromSet id im) -- overlap between im and the previously treated elements+      oldKeys = IntMap.elems overlap -- sets to which the overlapping items belong+      newKey = head oldKeys -- get any key name+      oldKeySet = IntSet.fromList oldKeys -- remove duplicates, provide efficient lookup+      -- newRev' is all items that will remain the same+      -- newItm' is all (old) items that must be renamed+      ~(newItm', newRev') = IntMap.partitionWithKey (\k _ -> IntSet.member k oldKeySet) rev+      newItm :: IntSet.IntSet+      newItm = IntSet.unions (im : IntMap.elems newItm') -- all +      newRev = IntMap.insert newKey newItm newRev'+      newElems = IntMap.union (IntMap.fromSet (const newKey) newItm) allElems -- overwrites some of the allElems items with the new key++findExact :: (Ord a, SetLike x) => Op1EqualitySystem a -> FreeLattice a -> x a -- returns the empty set on a failure+findExact = findWith lookupInRevMap (\x -> fromList [x])+findSubsets :: (Ord a, SetLike x) => Op1EqualitySystem a -> FreeLattice a -> [x a] -- returns a list of largest subsets+findSubsets = findWith findSubsetInRevMap (\x -> [fromList [x]])++findWith :: Ord a+  => ([Int] -> RevMap a -> b) -- Function that finds the normalized form+  -> (a -> b)                   -- Shorthand in case the FreeLattice does not need to go through the translation process+  -> Op1EqualitySystem a        -- system in which the FreeLattice elements can be found+  -> FreeLattice a              -- the FreeLattice that needs translation+  -> b+findWith f f2 es@(ES1 _ back _) trmUnsimplified+  = case trm of+     Atom x -> f2 x+     _ -> f (IntSet.toList (case trm' of+                       Just t -> intersections (map it t)+                       Nothing -> IntSet.empty+                     )+            ) back+  where it = simplifySet es+        intersections [] = IntSet.empty+        intersections x = foldr1 IntSet.intersection x+        trm' = latticeToTranslatable es trm+        trm = simpl trmUnsimplified+        simpl (Meet a b)+          = case (simpl a, simpl b) of+             (Atom a', Atom b') | a'==b' -> Atom a'+             (a',b') -> Meet a' b'+        simpl (Join a b)+          = case (simpl a, simpl b) of+             (Atom a', Atom b') | a'==b' -> Atom a'+             (a',b') -> Join a' b'+        simpl (Atom x) = Atom x++simplifySet :: Op1EqualitySystem t -> IntSet.IntSet -> IntSet.IntSet+simplifySet (ES1 _ _ imap) x = imapTranslate imap x IntSet.empty++latticeToTranslatable :: Ord a => Op1EqualitySystem a -> FreeLattice a -> Maybe [IntSet.IntSet]+latticeToTranslatable (ES1 m _ _) lt = t lt+ where+   t (Atom a)   = do{r<-Map.lookup a m;return [r]}+   t (Meet a b) = do{a'<-t a;b'<- t b;return [IntSet.union ta tb | ta <- a', tb <- b']}+   t (Join a b) = do{a'<-t a;b'<- t b;return (a'++b')}+   ++-- how to lookup something in a RevMap (Precondition: list is sorted!)+lookupInRevMap :: (Ord a, SetLike x) => [Int] -> RevMap a -> x a+lookupInRevMap [] (RevMap st _) = fromSet st+lookupInRevMap (a:as) (RevMap _ mp)+ = case IntMap.lookup a mp of+    Nothing -> slEmpty+    Just rm -> lookupInRevMap as rm++-- a bit slower: suppose we could not find our element in the RevMap, we find all subsets of it (as a RevMap)+findSubsetAsRevMap :: (Ord a) => [Int] -> RevMap a -> RevMap a+findSubsetAsRevMap [] (RevMap st _) = RevMap st IntMap.empty+findSubsetAsRevMap lst (RevMap st mp)+ = RevMap st (IntMap.fromList [ (l, rm)+                              | (l, rst) <- listAndRest lst+                              , (Just mp') <- [IntMap.lookup l mp]+                              , let rm@(RevMap st2 mp2) = findSubsetAsRevMap rst mp'+                              , not (Set.null st2 && IntMap.null mp2)+                              ] )++-- fins the largest subsets! (endpoints only)+findSubsetInRevMap :: (Ord a, SetLike x) => [Int] -> RevMap a -> [x a]+findSubsetInRevMap lst rm = largestSubset (findSubsetAsRevMap lst rm)++largestSubset :: (Ord a, SetLike x) => RevMap a -> [x a]+largestSubset i+ = elimSubsets (endPoints i)+ where elimSubsets ((a,v):as) = v : elimSubsets (filter (\x -> not (IntSet.isSubsetOf (fst x) a)) as)+       elimSubsets [] = []++endPoints :: (Ord a, SetLike x) => RevMap a -> [(IntSet.IntSet,x a)]+endPoints (RevMap st im)+ = if (IntMap.null im) then (if slNull st then [] else [(IntSet.empty,fromSet st)]) else concat (map endPoints' (IntMap.toList im))+ where endPoints' (i,rm) = map addi (endPoints rm)+        where addi (lst,elm) = (IntSet.insert i lst,elm)++listAndRest :: [t] -> [(t, [t])]+listAndRest [] = []+listAndRest (a:rst) = (a,rst):listAndRest rst+++data RevMap a+ = RevMap (Set.Set a) -- all elements equivalent to this point in the map+          (IntMap.IntMap (RevMap a)) -- recursive+          deriving Show++data Op1EqualitySystem a+ = ES1 (Map.Map a (IntSet.IntSet))+       (RevMap a)+       (IntMap.IntMap  -- map for: whenever you encounter this element i in your set y+         [( IntSet.IntSet -- when you find this set (that is: if it is a subset of y)+          , IntSet.IntSet -- add this set+          )]+       )++-- TODO: this function can be optimised a lot+reverseMap :: (Ord a) => [(a,[Int])] -> RevMap a+reverseMap lst+ = RevMap (Set.fromList (map fst empties)) (buildMap rest)+ where+   (empties,rest) = partition (null . snd) lst+   buildMap [] = IntMap.empty+   buildMap o@((_,~(f:_)):_)+     = IntMap.insert f (reverseMap (map tail2 h)) (buildMap tl)+     where tail2 (a,b) = (a, tail b)+           (h,tl) = partition ((== f) . head . snd) o+     +optimize1 :: Ord a => EqualitySystem a -> Op1EqualitySystem a+optimize1 (ES oldmap oldimap)+ = ES1 newmap+       (reverseMap (Map.toList (Map.map IntSet.toList newmap)))+       (IntMap.mapMaybe maybeMapper     oldimap)+ where notEmpty [] = Nothing+       notEmpty a = Just a+       maybeMapper :: [(IntSet.IntSet,IntSet.IntSet)] -> Maybe [(IntSet.IntSet,IntSet.IntSet)]+       maybeMapper x = notEmpty [ (s1,imapTranslate oldimap s2 (IntSet.empty)) +                                | (s1,s2) <- x+                                , not (IntSet.null s1)+                                , not (IntSet.null s2)+                                ]+       newmap = Map.map (\x -> imapTranslate oldimap (IntSet.singleton x) (IntSet.empty)) oldmap++addEquality :: (Ord a, SetLike x) => (x a, x a) -> EqualitySystem a -> EqualitySystem a+addEquality (set1, set2) eqSys0+ = addEquality' eqSys2 ns1 ns2+ where+   (eqSys1, ns1) = translateWith eqSys0 set1+   (eqSys2, ns2) = translateWith eqSys1 set2++addEquality' :: Ord a => EqualitySystem a -> IntSet.IntSet -> IntSet.IntSet -> EqualitySystem a+addEquality' ~(ES nms imap) set1 set2+ = ES nms (addRule (addRule imap set1 set1 uni) set2 (IntSet.difference set2 set1) uni)+ where+   uni = IntSet.union set1 set2+   addRule :: IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)] -> IntSet.IntSet -> IntSet.IntSet -> IntSet.IntSet -> IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)]+   addRule oldimap origSet triggers newSet+    = foldl updateMapForTrigger oldimap (IntSet.toList triggers)+    where dif = IntSet.difference newSet origSet+          updateMapForTrigger :: IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)] -> Int -> IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)]+          updateMapForTrigger mp trigger+           = IntMap.insertWith (++) trigger [(IntSet.delete trigger origSet, dif)] mp++translateWith :: (Ord a, SetLike x) => EqualitySystem a -> x a -> (EqualitySystem a, IntSet.IntSet)+translateWith ~(ES nomenclature imap) inSet+ = ( ES newNomenclature imap+   , IntSet.fromList$ map (newNomenclature Map.!) (getList inSet)+   )+ where+  newNomenclature+   = foldr (\x y -> if Map.member x y then y else Map.insert x (Map.size y) y) nomenclature (getList inSet)++imapTranslate :: IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)] -> IntSet.IntSet -> IntSet.IntSet -> IntSet.IntSet+imapTranslate imap tds doneSet+ = case IntSet.minView tds of+    Nothing -> doneSet+    Just (todo,set) -> imapTranslate imap (newSet todo set) (IntSet.insert todo doneSet)+ where+  newSet todo set+   = case IntMap.lookup todo imap of+       Nothing -> set+       Just lst -> IntSet.unions (set:[IntSet.difference tl doneSet | (fl,tl) <- lst, IntSet.isSubsetOf fl doneSet])++data FreeLattice a+ = Join (FreeLattice a) (FreeLattice a)+ | Meet (FreeLattice a) (FreeLattice a)+ | Atom a+ +instance SetLike [] where+  fromList = id+  fromSet = Set.toList+  toSet = Set.fromList+  getList = id+  slUnion a b = mrgUnion a b+  slIsect a b = mrgIsect a b+  slFold = foldl+  slNull = null+  slSize = length++instance SetLike Set.Set where+  slIsect = Set.intersection+  slUnion = Set.union+  slEmpty = Set.empty+  slUnions = Set.unions+  slMap = Set.map+  getList = Set.toList+  fromList = Set.fromList+  fromSet = id+  isElemOf = Set.member+  slFold f = Set.fold (flip f)+  slNull = Set.null+  slSize = Set.size+  slInsert = Set.insert+  toSet = id++class SetLike x where -- I dislike having to put Ord everywhere, is there another way? (Without including a in the class)+  slIsect :: Ord a => x a -> x a -> x a+  slUnion :: Ord a => x a -> x a -> x a+  getList :: Ord a => x a -> [a]+  fromList :: Ord a => [a] -> x a+  fromSet :: Ord a => Set.Set a -> x a+  slMap :: (Ord a,Ord b) => (a -> b) -> x a -> x b+  slMap f = fromList . nub' . sort . (map f) . getList+  slEmpty :: Ord a => x a+  slEmpty = fromList []+  slUnions :: Ord a => [x a] -> x a+  slUnions = foldr slUnion slEmpty+  isElemOf :: Ord a => a -> x a -> Bool+  isElemOf e mp = (e `elem` getList mp)+  slFold :: Ord b => (a -> b -> a) -> a -> x b -> a+  slFold f u xs = foldl f u (getList xs)+  slSize :: Ord a => x a -> Int+  slSize = length . getList+  slNull :: Ord a => x a -> Bool+  slNull = null . getList+  slInsert :: Ord a => a -> x a -> x a+  slInsert x = slUnion (fromList [x])+  toSet :: Ord a => x a -> Set.Set a+  ++nub' :: Eq a => [a] -> [a]+nub' (a:b:bs) | a == b = nub' (b:bs)+              | otherwise = a:nub' (b:bs)+nub' rst = rst++mrgUnion :: (Ord a) => [a] -> [a] -> [a]+mrgUnion (a:as) (b:bs) | a<b       = a:mrgUnion as (b:bs)+                       | a==b      = a:mrgUnion as bs+                       | otherwise = b:mrgUnion (a:as) bs+mrgUnion a b = a ++ b -- since either a or b is the empty list+{-# SPECIALIZE mrgUnion :: [Int] -> [Int] -> [Int] #-}++mrgIsect :: (Ord a) => [a] -> [a] -> [a]+mrgIsect (a:as) (b:bs) | a<b       = mrgIsect as (b:bs)+                       | a==b      = b: mrgIsect as bs+                       | otherwise = mrgIsect (a:as) bs+mrgIsect _ _ = [] -- since either a or b is the empty list+{-# SPECIALIZE mrgIsect :: [Int] -> [Int] -> [Int] #-}+
+ src/lib/DatabaseDesign/Ampersand/ADL1/P2A_Converters.hs view
@@ -0,0 +1,639 @@+{-# OPTIONS_GHC -Wall -XFlexibleInstances -XDataKinds #-}
+{-# LANGUAGE RelaxedPolyRec #-}
+module DatabaseDesign.Ampersand.ADL1.P2A_Converters (
+     -- * Exported functions
+     pCtx2aCtx, showErr,
+     Guarded(..)
+     )
+where
+import DatabaseDesign.Ampersand.ADL1.Disambiguate
+import DatabaseDesign.Ampersand.Core.ParseTree -- (P_Context(..), A_Context(..))
+import DatabaseDesign.Ampersand.Input.ADL1.CtxError
+import DatabaseDesign.Ampersand.ADL1.Lattices
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (sortWith, maxima, greatest)
+import DatabaseDesign.Ampersand.Basics (Identified(name), fatalMsg)
+import DatabaseDesign.Ampersand.Misc
+import Prelude hiding (head, sequence, mapM)
+import Control.Applicative
+import Data.Traversable
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Data.Maybe
+
+head :: [a] -> a
+head [] = fatal 30 "head must not be used on an empty list!"
+head (a:_) = a
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "ADL1.P2A_Converters"
+
+newtype SignOrd = SignOrd Sign
+instance Ord SignOrd where
+  compare (SignOrd (Sign a b)) (SignOrd (Sign c d)) = compare (name a,name b) (name c,name d)
+instance Eq SignOrd where
+  (==) (SignOrd (Sign a b)) (SignOrd (Sign c d)) = (name a,name b) == (name c,name d)
+
+pCtx2aCtx :: P_Context -> Guarded A_Context
+pCtx2aCtx 
+ PCtx { ctx_nm     = n1
+      , ctx_pos    = n2
+      , ctx_lang   = lang
+      , ctx_markup = pandocf
+      , ctx_thms   = n3
+      , ctx_pats   = p_patterns     -- The patterns defined in this context
+      , ctx_PPrcs  = p_processes    --  The processes as defined by the parser
+      , ctx_rs     = p_rules        --  All user defined rules in this context, but outside patterns and outside processes
+      , ctx_ds     = p_declarations --  The declarations defined in this context, outside the scope of patterns
+      , ctx_cs     = p_conceptdefs  --  The concept definitions defined in this context, outside the scope of patterns
+      , ctx_ks     = p_identdefs    --  The identity definitions defined in this context, outside the scope of patterns
+      , ctx_vs     = p_viewdefs     --  The view definitions defined in this context, outside the scope of patterns
+      , ctx_gs     = p_gens         --  The gen definitions defined in this context, outside the scope of patterns
+      , ctx_ifcs   = p_interfaces   --  The interfaces defined in this context, outside the scope of patterns
+      , ctx_ps     = p_purposes     --  The purposes defined in this context, outside the scope of patterns
+      , ctx_pops   = p_pops         --  The populations defined in this context
+      , ctx_sql    = p_sqldefs      --  user defined sqlplugs, taken from the Ampersand script
+      , ctx_php    = p_phpdefs      --  user defined phpplugs, taken from the Ampersand script
+      , ctx_metas  = p_metas        --  generic meta information (name/value pairs) that can be used for experimenting without having to modify the adl syntax
+      }
+ = (\pats procs rules identdefs viewdefs interfaces purposes udpops sqldefs phpdefs
+     -> ACtx{ ctxnm = n1
+            , ctxpos = n2
+            , ctxlang = deflangCtxt
+            , ctxmarkup = deffrmtCtxt
+            , ctxthms = n3
+            , ctxpats = pats               --  The patterns defined in this context
+            , ctxprocs = procs             --  The processes defined in this context
+            , ctxrs = rules                --  All user defined rules in this context, outside the scope of patterns and processes
+            , ctxds = ctxDecls             --  The declarations defined in this context, outside the scope of patterns
+            , ctxpopus = udpops            --  The user defined populations of relations defined in this context, outside the scope of patterns and processes
+            , ctxcds = p_conceptdefs       --  The concept definitions defined in this context, outside the scope of patterns and processes
+            , ctxks = identdefs            --  The identity definitions defined in this context, outside the scope of patterns
+            , ctxvs = viewdefs             --  The view definitions defined in this context, outside the scope of patterns
+            , ctxgs = map pGen2aGen p_gens --  The specialization statements defined in this context, outside the scope of patterns
+            , ctxgenconcs = map (map findConcept) (concGroups ++ map (:[]) soloConcs) --  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
+                                           --  for each class<-ctxgenconcs context: c,c'<-class:   c `join` c' exists (although there is not necessarily a concept d=c `join` c'    ...)
+            , ctxifcs = interfaces         --  The interfaces defined in this context, outside the scope of patterns
+            , ctxps = purposes             --  The purposes of objects defined in this context, outside the scope of patterns
+            , ctxsql = sqldefs             --  user defined sqlplugs, taken from the Ampersand script
+            , ctxphp = phpdefs             --  user defined phpplugs, taken from the Ampersand script
+            , ctxmetas = p_metas
+            }
+    ) <$> traverse pPat2aPat p_patterns            --  The patterns defined in this context
+      <*> traverse pProc2aProc p_processes         --  The processes defined in this context
+      <*> traverse (pRul2aRul [] n1) p_rules          --  All user defined rules in this context, but outside patterns and outside processes
+      <*> traverse pIdentity2aIdentity p_identdefs --  The identity definitions defined in this context, outside the scope of patterns
+      <*> traverse pViewDef2aViewDef p_viewdefs    --  The view definitions defined in this context, outside the scope of patterns
+      <*> traverse pIfc2aIfc p_interfaces          --  The interfaces defined in this context, outside the scope of patterns
+      <*> traverse pPurp2aPurp p_purposes          --  The purposes of objects defined in this context, outside the scope of patterns
+      <*> traverse pPop2aPop p_pops                --  [Population]
+      <*> traverse pObjDef2aObjDef p_sqldefs       --  user defined sqlplugs, taken from the Ampersand script
+      <*> traverse pObjDef2aObjDef p_phpdefs       --  user defined phpplugs, taken from the Ampersand script
+  where
+    -- story about genRules and genLattice
+    -- the genRules is a list of equalities between concept sets, in which every set is interpreted as a conjunction of concepts
+    -- the genLattice is the resulting optimized structure
+    genRules = [ ( Set.singleton (name (gen_spc x)), Set.fromList (map name (gen_concs x)))
+               | x <- p_gens ++ concat (map pt_gns p_patterns ++ map procGens p_processes)
+               ]
+    genLattice :: Op1EqualitySystem String
+    genLattice = optimize1 (foldr addEquality emptySystem genRules)
+    
+    concGroups :: [[String]]
+    concGroups = getGroups genLattice
+    allConcs :: Set.Set String
+    allConcs = Set.fromList (map (name . source) decls ++ map (name . target) decls)
+    soloConcs :: [String]
+    soloConcs = filter (not . isInSystem genLattice) (Set.toList allConcs)
+    
+    deflangCtxt = fromMaybe English lang
+    deffrmtCtxt = fromMaybe HTML pandocf
+
+    decls = ctxDecls++patDecls++patProcs
+    ctxDecls = [ pDecl2aDecl n1         deflangCtxt deffrmtCtxt pDecl | pDecl<-p_declarations ] --  The declarations defined in this context, outside the scope of patterns
+    patDecls = [ pDecl2aDecl (name pat) deflangCtxt deffrmtCtxt pDecl | pat<-p_patterns, pDecl<-pt_dcs pat ] --  The declarations defined in all patterns within this context.
+    patProcs = [ pDecl2aDecl (name prc) deflangCtxt deffrmtCtxt pDecl | prc<-p_processes, pDecl<-procDcls prc ] --  The declarations defined in all processes within this context.
+      
+    declMap = Map.map groupOnTp (Map.fromListWith (++) [(name d,[d]) | d <- decls])
+      where groupOnTp lst = Map.fromListWith accumDecl [(SignOrd$ sign d,d) | d <- lst]
+    findDecls x = Map.findWithDefault Map.empty x declMap
+    findDecl o x = getOneExactly o . Map.elems $ findDecls x
+    findDeclsTyped x tp = Map.findWithDefault [] (SignOrd tp) (Map.map (:[]) (findDecls x))
+    findDeclTyped o x tp = getOneExactly o (findDeclsTyped x tp)
+    -- accumDecl is the function that combines two declarations into one
+    -- meanings, for instance, two should get combined into a list of meanings, et cetera
+    -- positions are combined
+    -- TODO
+    accumDecl :: Declaration -> Declaration -> Declaration
+    accumDecl a _ = a
+    
+    pPop2aPop :: P_Population -> Guarded Population
+    pPop2aPop P_CptPopu { p_cnme = cnm, p_popas = ps }
+     = pure PCptPopu{ popcpt = findConcept cnm, popas = ps }
+    pPop2aPop orig@(P_RelPopu { p_rnme = rnm, p_popps = ps })
+     = fmap (\dcl -> PRelPopu { popdcl = dcl, popps = ps})
+            (findDecl orig rnm)
+    pPop2aPop orig@(P_TRelPop { p_rnme = rnm, p_type = tp, p_popps = ps })
+     = fmap (\dcl -> PRelPopu { popdcl = dcl, popps = ps})
+            (findDeclTyped orig rnm (pSign2aSign tp))
+    
+    pObjDef2aObjDef :: P_ObjectDef -> Guarded ObjectDef
+    pObjDef2aObjDef x = fmap fst (typecheckObjDef tpda)
+     where tpda = disambiguate termPrimDisAmb x
+     
+    pViewDef2aViewDef :: P_ViewDef -> Guarded ViewDef
+    pViewDef2aViewDef x = typecheckViewDef tpda
+     where tpda = disambiguate termPrimDisAmb x
+     
+    typecheckViewDef :: P_ViewD (TermPrim, DisambPrim) -> Guarded ViewDef
+    typecheckViewDef
+       o@(P_Vd { vd_pos = orig
+            , vd_lbl = lbl -- String
+            , vd_cpt = cpt -- Concept
+            , vd_ats = pvs -- view segment
+            })
+     = (\vdts
+        -> Vd { vdpos = orig
+              , vdlbl = lbl
+              , vdcpt = pCpt2aCpt cpt
+              , vdats = vdts
+              })
+       <$> traverse (typeCheckViewSegment o) pvs
+    
+    typeCheckViewSegment :: (P_ViewD a) -> (P_ViewSegmt (TermPrim, DisambPrim)) -> Guarded ViewSegment
+    typeCheckViewSegment o P_ViewExp{ vs_obj = ojd }
+     = (\(obj,b) -> case findExact genLattice (mIsc c (name (source (objctx obj)))) of
+                      [] -> mustBeOrdered o o (Src,(source (objctx obj)),obj)
+                      r  -> if b || c `elem` r then pure (ViewExp obj{objctx = addEpsilonLeft c r (name (source (objctx obj))) (objctx obj)})
+                            else mustBeBound (origin obj) [(Tgt,objctx obj)]
+       ) <?> typecheckObjDef ojd
+     where c = name (vd_cpt o)
+    typeCheckViewSegment _ P_ViewText { vs_txt = txt } = pure$ ViewText txt
+    typeCheckViewSegment _ P_ViewHtml { vs_htm = htm } = pure$ ViewHtml htm
+    
+    typecheckObjDef :: (P_ObjDef (TermPrim, DisambPrim)) -> Guarded (ObjectDef, Bool)
+    typecheckObjDef o@(P_Obj { obj_nm = nm
+                             , obj_pos = orig
+                             , obj_ctx = ctx
+                             , obj_msub = subs
+                             , obj_strs = ostrs
+                             })
+     = (\(expr,subi)
+        -> case subi of
+            Nothing -> pure (obj expr Nothing)
+            Just (InterfaceRef s) -> pure (obj expr (Just$InterfaceRef s)) --TODO: check type!
+            Just b@(Box c _)
+              -> case findExact genLattice (mjoin (name c) (gc Tgt (fst expr))) of
+                    [] -> mustBeOrdered o (Src,c,((\(Just x)->x) subs)) (Tgt,target (fst expr),(fst expr))
+                    r  -> if (name c) `elem` r
+                          then pure (obj (addEpsilonRight' (name c) (fst expr), snd expr) (Just$ b))
+                          else mustBeBound (origin o) [(Tgt,fst expr)]
+       ) <?> ((,) <$> typecheckTerm ctx <*> maybeOverGuarded pSubi2aSubi subs)
+     where
+      obj (e,(sr,_)) s
+       = ( Obj { objnm = nm
+               , objpos = orig
+               , objctx = e
+               , objmsub = s
+               , objstrs = ostrs
+               }, sr)
+    addEpsilonLeft :: String -> [String] -> String -> Expression -> Expression
+    addEpsilonLeft a b c e
+     = if a==c then (if c `elem` b then e else fatal 200 "b == c must hold: the concept of the epsilon relation should be equal to the intersection of its source and target")
+               else if c/=name (source e) then fatal 202 ("addEpsilonLeft glues erroneously: c="++show c++"  and e="++show e++".")
+                    else EEps (findConceptOrONE (head b)) (findSign a c) .:. e
+    addEpsilonLeft',addEpsilonRight' :: String -> Expression -> Expression
+    addEpsilonLeft' a e
+     = if a==name (source e) then e else EEps (findConceptOrONE a) (findSign a (name (source e))) .:. e
+    addEpsilonRight' a e
+     = if a==name (target e) then e else e .:. EEps (findConceptOrONE a) (findSign (name (target e)) a)
+    addEpsilon :: String -> String -> Expression -> Expression
+    addEpsilon s t e
+     = (if s==name (source e) then id else (EEps (findConceptOrONE s) (findSign s (name (source e))) .:.)) $
+       (if t==name (target e) then id else (.:. EEps (findConceptOrONE t) (findSign (name (target e)) t))) e
+    
+    pSubi2aSubi :: (P_SubIfc (TermPrim, DisambPrim)) -> Guarded SubInterface
+    pSubi2aSubi (P_InterfaceRef _ s) = pure (InterfaceRef s)
+    pSubi2aSubi o@(P_Box _ []) = hasNone [] o
+    pSubi2aSubi o@(P_Box _ l)
+     = (\lst -> case findExact genLattice (foldr1 Join (map (Atom . name . source . objctx . fst) lst)) of
+                  [] -> mustBeOrderedLst o [(source (objctx a),Src, a) | (a,_) <- lst]
+                  r -> case [ objctx a
+                            | (a,False) <- lst
+                            , not ((name . source . objctx $ a) `elem` r)
+                            ] of
+                            [] -> pure (Box (findConceptOrONE (head r)) (map fst lst))
+                            lst' -> mustBeBound (origin o) [(Src,expr)| expr<-lst']
+       ) <?> (traverse typecheckObjDef l <* uniqueNames l)
+    
+    
+    typecheckTerm :: Term (TermPrim, DisambPrim) -> Guarded (Expression, (Bool, Bool))
+    typecheckTerm tct
+     = case tct of
+         Prim (t,v) -> (\x -> (x, case t of
+                                   PVee _ -> (False,False)
+                                   _ -> (True,True)
+                                   )) <$> pDisAmb2Expr (t,v)
+         Pequ _ a b -> binary  (.==.) (MBE (Src,fst) (Src,snd), MBE (Tgt,fst) (Tgt,snd)) <?> ((,)<$>tt a<*>tt b) 
+         Pimp _ a b -> binary  (.|-.) (MBG (Src,snd) (Src,fst), MBG (Tgt,snd) (Tgt,fst)) <?> ((,)<$>tt a<*>tt b)
+         PIsc _ a b -> binary  (./\.) (ISC (Src,fst) (Src,snd), ISC (Tgt,fst) (Tgt,snd)) <?> ((,)<$>tt a<*>tt b)
+         PUni _ a b -> binary  (.\/.) (UNI (Src,fst) (Src,snd), UNI (Tgt,fst) (Tgt,snd)) <?> ((,)<$>tt a<*>tt b)
+         PDif _ a b -> binary  (.-.)  (MBG (Src,fst) (Src,snd), MBG (Tgt,fst) (Tgt,snd)) <?> ((,)<$>tt a<*>tt b)
+         PLrs _ a b -> binary' (./.)  (MBG (Tgt,snd) (Tgt,fst)) ((Src,fst),(Src,snd))    <?> ((,)<$>tt a<*>tt b)
+         PRrs _ a b -> binary' (.\.)  (MBG (Src,fst) (Src,snd)) ((Tgt,fst),(Tgt,snd))    <?> ((,)<$>tt a<*>tt b)
+         PCps _ a b -> binary' (.:.)  (ISC (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd))    <?> ((,)<$>tt a<*>tt b)
+         PRad _ a b -> binary' (.!.)  (MBE (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd))    <?> ((,)<$>tt a<*>tt b)
+         PPrd _ a b -> (\((x,(s,_)),(y,(_,t))) -> (x .*. y, (s,t))) <$> ((,)<$>tt a<*>tt b)
+         PKl0 _ a   -> unary   EKl0   (UNI (Src, id) (Tgt, id), UNI (Src, id) (Tgt, id)) <?> tt a
+         PKl1 _ a   -> unary   EKl1   (UNI (Src, id) (Tgt, id), UNI (Src, id) (Tgt, id)) <?> tt a
+         PFlp _ a   -> (\(x,(s,t)) -> ((EFlp x), (t,s))) <$> tt a
+         PCpl _ a   -> (\(x,_) -> (ECpl x,(False,False))) <$> tt a
+         PBrk _ e   -> (\(x,t) -> (EBrk x,t)) <$> tt e
+     where
+      o = origin (fmap fst tct)
+      tt = typecheckTerm
+      -- SJC: Here is what binary, binary' and unary do:
+      -- (1) Create an expression, the combinator for this is given by its first argument
+      -- (2) Fill in the corresponding type-checked terms to that expression
+      -- (3) For binary' only: fill in the intermediate concept too
+      -- (4) Fill in the type of the new expression
+      -- For steps (3) and (4), you can use the `TT' data type to specify the new type, and what checks should occur:
+      -- If you don't know what to use, try MBE: it is the strictest form.
+      -- In the steps (3) and (4), different type errors may arise:
+      -- If the type does not exist, this yields a type error.
+      -- Some types may be generalized, while others may not.
+      -- When a type may be generalized, that means that the value of the expression does not change if the type becomes larger
+      -- When a type may not be generalized:
+      --   the type so far is actually just an estimate
+      --   it must be bound by the context to something smaller, or something as big
+      --   a way to do this, is by using (V[type] /\ thingToBeBound)
+      -- More details about generalizable types can be found by looking at "deriv1".
+      binary :: (Expression -> Expression->Expression) -- combinator
+             -> ( TT ( SrcOrTgt
+                     , ( (Expression, (Bool, Bool))
+                       , (Expression, (Bool, Bool))
+                       ) -> (Expression, (Bool, Bool))
+                     )
+                , TT ( SrcOrTgt
+                     , ( (Expression, (Bool, Bool))
+                       , (Expression, (Bool, Bool))
+                       ) -> (Expression, (Bool, Bool))
+                     )
+                ) -- simple instruction on how to derive the type
+             -> ((Expression,(Bool,Bool)), (Expression,(Bool,Bool))) -- expressions to feed into the combinator after translation
+             -> Guarded (Expression,(Bool,Bool))
+      binary  cbn     tp (e1,e2) = wrap'' cbn (fst e1,fst e2) <$> deriv tp (e1,e2)
+      unary   cbn     tp e1      = wrap   cbn (fst e1       ) <$> deriv tp e1
+      binary' cbn cpt tp (e1,e2) = wrap'  cbn (fst e1,fst e2) <$> deriv1 o (fmap (resolve (e1,e2)) cpt) <*> deriv' tp (e1,e2)
+      wrap'' f (e1,e2) ((src,b1), (tgt,b2)) = (f (addEpsilon src tgt e1) (addEpsilon src tgt e2), (b1, b2))
+      wrap   f expr  ((src,b1), (tgt,b2))  = (f (addEpsilon src tgt expr), (b1, b2))
+      wrap'  f (e1,e2) (cpt,_) ((_,b1), (_,b2))  = (f (addEpsilonRight' cpt e1) (addEpsilonLeft' cpt e2), (b1, b2))
+      deriv (t1,t2) es = (,) <$> deriv1 o (fmap (resolve es) t1) <*> deriv1 o (fmap (resolve es) t2)
+    
+    deriv1 o x'
+     = case x' of
+        (MBE a@(p1,(e1,b1)) b@(p2,(e2,b2))) ->
+             if (b1 && b2) || (gc p1 e1 == gc p2 e2) then (\x -> (x,b1||b2)) <$> getExactType mjoin (p1, e1) (p2, e2)
+             else mustBeBound o [(p,e) | (p,(e,False))<-[a,b]]
+        (MBG (p1,(e1,b1)) (p2,(e2,b2))) ->
+             (\x -> (x,b1)) <$> getAndCheckType mjoin (p1, True, e1) (p2, b2, e2)
+        (UNI (p1,(e1,b1)) (p2,(e2,b2))) ->
+             (\x -> (x,b1 && b2)) <$> getAndCheckType mjoin (p1, b1, e1) (p2, b2, e2)
+        (ISC (p1,(e1,b1)) (p2,(e2,b2))) ->
+             (\x -> (x,b1 || b2)) <$> getAndCheckType mIsc  (p1, b1, e1) (p2, b2, e2)
+     where
+      getExactType flf (p1,e1) (p2,e2)
+       = case findExact genLattice (flf (gc p1 e1) (gc p2 e2)) of
+          [] -> mustBeOrdered o (p1,e1) (p2,e2)
+          r  -> pure$ head r
+      getAndCheckType flf (p1,b1,e1) (p2,b2,e2)
+       = case findSubsets genLattice (flf (gc p1 e1) (gc p2 e2)) of -- note: we could have used GetOneGuarded, but this is more specific
+          []  -> mustBeOrdered o (p1,e1) (p2,e2)
+          [r] -> case (b1 || Set.member (gc p1 e1) r,b2 || Set.member (gc p2 e2) r ) of
+                   (True,True) -> pure (head' (Set.toList r))
+                   (a,b) -> mustBeBound o [(p,e) | (False,p,e)<-[(a,p1,e1),(b,p2,e2)]]
+          lst -> mustBeOrderedConcLst o (p1,e1) (p2,e2) (map (map findConceptOrONE . Set.toList) lst)
+       where head' [] =fatal 321 ("empty list on expressions "++show ((p1,b1,e1),(p2,b2,e2)))
+             head' (a:_) = a
+    termPrimDisAmb :: TermPrim -> (TermPrim, DisambPrim)
+    termPrimDisAmb x
+     = (x, case x of
+           PI _        -> Ident
+           Pid _ conspt-> Known (EDcI (pCpt2aCpt conspt))
+           Patm _ s Nothing -> Mp1 s
+           Patm _ s (Just conspt) -> Known (EMp1 s (pCpt2aCpt conspt))
+           PVee _      -> Vee
+           Pfull _ a b -> Known (EDcV (Sign (pCpt2aCpt a) (pCpt2aCpt b)))
+           Prel _ r    -> Rel [EDcD dc | dc <- (Map.elems $ findDecls r)]
+           PTrel _ r s -> Rel [EDcD dc | dc <- (findDeclsTyped r (pSign2aSign s))]
+        )
+    
+    termPrim2Decl :: TermPrim -> Guarded Declaration
+    termPrim2Decl o@(Prel _ r   ) = getOneExactly o [ dc | dc <- (Map.elems $ findDecls r)]
+    termPrim2Decl o@(PTrel _ r s) = getOneExactly o [ dc | dc <- (findDeclsTyped r (pSign2aSign s))]
+    termPrim2Decl _ = fatal 231 "Expecting Declaration"
+    termPrim2Expr :: TermPrim -> Guarded Expression
+    termPrim2Expr = pDisAmb2Expr . termPrimDisAmb
+    
+    pIfc2aIfc :: P_Interface -> Guarded Interface
+    pIfc2aIfc P_Ifc { ifc_Params = tps
+                    , ifc_Args = args
+                    , ifc_Roles = rols
+                    , ifc_Obj = obj
+                    , ifc_Pos = orig
+                    -- , ifc_Name = nm
+                    , ifc_Prp = prp
+                    }
+        = (\ tps' obj'
+             -> Ifc { ifcParams = tps'
+                    , ifcArgs = args
+                    , ifcRoles = rols
+                    , ifcObj = obj'
+                    , ifcPos = orig
+                    , ifcPrp = prp
+                    }) <$> traverse termPrim2Expr tps
+                       <*> pObjDef2aObjDef obj
+    pProc2aProc :: P_Process -> Guarded Process
+    pProc2aProc P_Prc { procNm = nm
+                      , procPos = orig
+                      , procEnd = posEnd
+                      , procRules = ruls
+                      , procGens = gens
+                      , procDcls = dcls
+                      , procRRuls = rolruls
+                      , procRRels = rolrels
+                      , procCds = _cdefs -- SJ2013: the underscore means that this argument is not used.
+                      , procIds = idefs
+                      , procVds = viewdefs
+                      , procXps = purposes
+                      , procPop = pops
+                      }
+     = (\ ruls' rels' pops' idefs' viewdefs' purposes'
+            ->  Proc { prcNm = nm
+                     , prcPos = orig
+                     , prcEnd = posEnd
+                     , prcRules = map snd ruls'
+                     , prcGens = map pGen2aGen gens
+                     , prcDcls = [ pDecl2aDecl nm deflangCtxt deffrmtCtxt pDecl | pDecl<-dcls ]
+                     , prcUps = pops'
+                     , prcRRuls = [(rol,r)|(rols,r)<-ruls',rol<-rols]
+                     , prcRRels = [(rol,r)|(rols,rs)<-rels',rol<-rols,r<-rs]
+                     , prcIds = idefs'
+                     , prcVds = viewdefs'
+                     , prcXps = purposes'
+                     }
+       ) <$> traverse (\x -> pRul2aRul' [rol | rr <- rolruls, rul <- mRules rr, name x == rul, rol <- mRoles rr] nm x) ruls
+         <*> sequenceA [(\x -> (rr_Roles prr,x)) <$> (traverse termPrim2Decl $ rr_Rels prr) | prr <- rolrels]
+         <*> traverse pPop2aPop pops
+         <*> traverse pIdentity2aIdentity idefs
+         <*> traverse pViewDef2aViewDef viewdefs
+         <*> traverse pPurp2aPurp purposes
+    
+    pPat2aPat :: P_Pattern -> Guarded Pattern
+    pPat2aPat ppat
+     = f <$> parRuls ppat <*> parKeys ppat <*> parPops ppat <*> parViews ppat <*> parPrps ppat <*> sequenceA rrels
+       where
+        f prules keys' pops' views' xpls rrels'
+         = A_Pat { ptnm  = name ppat
+                 , ptpos = pt_pos ppat
+                 , ptend = pt_end ppat
+                 , ptrls = map snd prules
+                 , ptgns = agens'
+                 , ptdcs = [ pDecl2aDecl (name ppat) deflangCtxt deffrmtCtxt pDecl | pDecl<-pt_dcs ppat ]
+                 , ptups = pops'
+                 , ptrruls = [(rol,r)|(rols,r)<-prules,rol<-rols]
+                 , ptrrels = [(rol,dcl)|rr<-rrels', rol<-rrRoles rr, dcl<-rrRels rr]  -- The assignment of roles to Relations.
+                 , ptids = keys'
+                 , ptvds = views'
+                 , ptxps = xpls
+                 }
+        agens'   = map pGen2aGen (pt_gns ppat)
+        parRuls  = traverse (\x -> pRul2aRul' [rol | prr <- pt_rus ppat, rul<-mRules prr, name x == rul, rol<-mRoles prr] (name ppat) x) . pt_rls
+        rrels :: [Guarded RoleRelation]
+        rrels =  [(\x -> RR (rr_Roles prr) x (origin prr)) <$> (traverse termPrim2Decl $ rr_Rels prr) | prr <- pt_res ppat]
+        parKeys  = traverse pIdentity2aIdentity . pt_ids
+        parPops  = traverse pPop2aPop . pt_pop
+        parViews = traverse pViewDef2aViewDef . pt_vds
+        parPrps  = traverse pPurp2aPurp . pt_xps
+    
+    pRul2aRul':: [String] -- list of roles for this rule
+              -> String -- environment name (pattern / proc name)
+              -> (P_Rule TermPrim) -> Guarded ([String],Rule)  -- roles in the lhs
+    pRul2aRul' a b c = fmap ((,) a) (pRul2aRul a b c)
+    pRul2aRul :: [String] -- list of roles for this rule
+              -> String -- environment name (pattern / proc name)
+              -> (P_Rule TermPrim) -> Guarded Rule
+    pRul2aRul rol env = typeCheckRul rol env . disambiguate termPrimDisAmb
+    typeCheckRul :: [String] -- list of roles for this rule
+              -> String -- environment name (pattern / proc name)
+              -> (P_Rule (TermPrim, DisambPrim)) -> Guarded Rule
+    typeCheckRul sgl env P_Ru { rr_nm = nm
+                       , rr_exp = expr
+                       , rr_fps = orig
+                       , rr_mean = meanings
+                       , rr_msg = msgs
+                       , rr_viol = viols
+                       }
+     = (\ (exp',_)
+       -> (\ vls ->
+          Ru { rrnm = nm
+             , rrexp = exp'
+             , rrfps = orig
+             , rrmean = pMean2aMean deflangCtxt deffrmtCtxt meanings
+             , rrmsg = map (pMess2aMess deflangCtxt deffrmtCtxt) msgs
+             , rrviol = vls
+             , rrtyp = sign exp'
+             , rrdcl = Nothing
+             , r_env = env
+             , r_usr = UserDefined
+             , r_sgl = not (null sgl)
+             , srrel = Sgn{ decnm = nm
+                          , decsgn = (sign exp')
+                          , decprps = []
+                          , decprps_calc = Nothing
+                          , decprL = ""
+                          , decprM = ""
+                          , decprR = ""
+                          , decMean = pMean2aMean deflangCtxt deffrmtCtxt meanings
+                          , decConceptDef = Nothing
+                          , decfpos = orig
+                          , decissX = True
+                          , decusrX = False
+                          , decISA = False
+                          , decpat = env
+                          , decplug = False
+                          }
+             }
+             ) <$> maybeOverGuarded (typeCheckPairView orig exp') viols
+          ) <?> typecheckTerm expr
+    pIdentity2aIdentity :: P_IdentDef -> Guarded IdentityDef
+    pIdentity2aIdentity
+            P_Id { ix_pos = orig
+                 , ix_lbl = lbl
+                 , ix_cpt = pconc
+                 , ix_ats = isegs
+                 }
+     = (\isegs' ->
+       Id { idPos = orig
+          , idLbl = lbl
+          , idCpt = pCpt2aCpt pconc
+          , identityAts = isegs'
+          }) <$> traverse pIdentSegment2IdentSegment isegs
+    pIdentSegment2IdentSegment :: P_IdentSegment -> Guarded IdentitySegment
+    pIdentSegment2IdentSegment (P_IdentExp ojd)
+     = IdentityExp <$> pObjDef2aObjDef ojd
+    
+    typeCheckPairView :: Origin -> Expression -> PairView (Term (TermPrim, DisambPrim)) -> Guarded (PairView Expression)
+    typeCheckPairView o x (PairView lst)
+     = PairView <$> traverse (typeCheckPairViewSeg o x) lst
+    typeCheckPairViewSeg :: Origin -> Expression -> (PairViewSegment (Term (TermPrim, DisambPrim))) -> Guarded (PairViewSegment Expression)
+    typeCheckPairViewSeg _ _ (PairViewText x) = pure (PairViewText x)
+    typeCheckPairViewSeg o t (PairViewExp s x)
+     = (\(e,(b,_)) -> case (findSubsets genLattice (mjoin (name (source e)) (gc s t))) of
+                        [] -> mustBeOrdered o (Src,e) (s,t)
+                        lst -> if b || and (map (name (source e) `elem`) lst)
+                               then pure (PairViewExp s e)
+                               else mustBeBound o [(Src, e)]
+                        ) <?> typecheckTerm x
+
+    pPurp2aPurp :: PPurpose -> Guarded Purpose
+    pPurp2aPurp PRef2 { pexPos = orig
+                      , pexObj = objref
+                      , pexMarkup= pmarkup
+                      , pexRefID = refId
+                      }
+     = (\ obj -> Expl { explPos = orig
+                      , explObj = obj
+                      , explMarkup = pMarkup2aMarkup deflangCtxt deffrmtCtxt pmarkup
+                      , explUserdefd = True
+                      , explRefId = refId
+                      })
+       <$> pRefObj2aRefObj objref
+    pRefObj2aRefObj :: PRef2Obj -> Guarded ExplObj
+    pRefObj2aRefObj (PRef2ConceptDef  s ) = pure$ ExplConceptDef (lookupConceptDef s)
+    pRefObj2aRefObj (PRef2Declaration tm) = ExplDeclaration <$> (termPrim2Decl tm)
+    pRefObj2aRefObj (PRef2Rule        s ) = pure$ ExplRule s
+    pRefObj2aRefObj (PRef2IdentityDef s ) = pure$ ExplIdentityDef s
+    pRefObj2aRefObj (PRef2ViewDef     s ) = pure$ ExplViewDef s
+    pRefObj2aRefObj (PRef2Pattern     s ) = pure$ ExplPattern s
+    pRefObj2aRefObj (PRef2Process     s ) = pure$ ExplProcess s
+    pRefObj2aRefObj (PRef2Interface   s ) = pure$ ExplInterface s
+    pRefObj2aRefObj (PRef2Context     s ) = pure$ ExplContext s
+    pRefObj2aRefObj (PRef2Fspc        s ) = pure$ ExplContext s
+    lookupConceptDef :: String -> ConceptDef
+    lookupConceptDef s = if null cs then fatal 460 ("There is no concept called "++s++". Please check for typing mistakes.") else head cs
+              where cs = [cd | cd<-conceptDefs, name cd==s]
+    conceptDefs = p_conceptdefs++concat (map pt_cds p_patterns)++concat (map procCds p_processes)
+    
+pDisAmb2Expr :: (TermPrim, DisambPrim) -> Guarded Expression
+pDisAmb2Expr (_,Known x) = pure x
+pDisAmb2Expr (_,Rel [x]) = pure x
+pDisAmb2Expr (o,Rel rs)  = cannotDisambRel o rs
+pDisAmb2Expr (o,_)       = cannotDisamb o
+
+pMean2aMean :: Lang           -- The default language 
+  -> PandocFormat   -- The default pandocFormat
+  -> [PMeaning] -> AMeaning
+pMean2aMean a b xs = AMeaning (map (\(PMeaning c) -> pMarkup2aMarkup a b c) xs)
+pMess2aMess :: Lang           -- The default language 
+  -> PandocFormat   -- The default pandocFormat
+  -> PMessage -> A_Markup
+pMess2aMess a b (PMessage x) = pMarkup2aMarkup a b x
+pMarkup2aMarkup :: 
+     Lang           -- The default language 
+  -> PandocFormat   -- The default pandocFormat
+  -> P_Markup -> A_Markup 
+pMarkup2aMarkup defLanguage defFormat
+   P_Markup  { mLang = ml
+             , mFormat = mpdf
+             , mString = str
+             }
+ = A_Markup { amLang = fromMaybe defLanguage ml
+            , amFormat = fmt
+            , amPandoc = string2Blocks fmt str
+            }
+     where
+       fmt = fromMaybe defFormat mpdf
+pDecl2aDecl :: 
+     String         -- The name of the pattern
+  -> Lang           -- The default language 
+  -> PandocFormat   -- The default pandocFormat
+  -> P_Declaration -> Declaration
+pDecl2aDecl patNm defLanguage defFormat pd
+ = Sgn { decnm   = dec_nm pd
+       , decsgn  = pSign2aSign (dec_sign pd)
+       , decprps = dec_prps pd
+       , decprps_calc = Nothing  --decprps_calc in an A_Context are still the user-defined only. prps are calculated in adl2fspec.
+       , decprL  = dec_prL pd
+       , decprM  = dec_prM pd
+       , decprR  = dec_prR pd
+       , decMean = AMeaning [ pMarkup2aMarkup defLanguage defFormat meaning | PMeaning meaning<-dec_Mean pd ]
+       , decConceptDef = dec_conceptDef pd
+       , decfpos = dec_fpos pd 
+       , decissX = True
+       , decusrX = True
+       , decISA  = False
+       , decpat  = patNm
+       , decplug = dec_plug pd
+       }
+
+pSign2aSign :: P_Sign -> Sign
+pSign2aSign (P_Sign src tgt) = Sign (pCpt2aCpt src) (pCpt2aCpt tgt)
+
+-- helpers for generating a lattice, not having to write `Atom' all the time
+mjoin,mIsc :: a -> a -> FreeLattice a
+mjoin a b = Join (Atom a) (Atom b)
+mIsc  a b = Meet (Atom a) (Atom b)
+-- intended for finding the right expression on terms like (Src,fst)
+resolve :: t -> (SrcOrTgt, t -> (t1, (t2, t2))) -> (SrcOrTgt, (t1, t2))
+resolve es (p,f)
+ = case (p,f es) of
+  (Src,(e,(b,_))) -> (Src,(e,b))
+  (Tgt,(e,(_,b))) -> (Tgt,(e,b))
+
+pGen2aGen :: P_Gen -> A_Gen
+pGen2aGen pg@PGen{}
+   = Isa{genfp  = gen_fp pg
+        ,gengen = pCpt2aCpt (gen_gen pg)
+        ,genspc = pCpt2aCpt (gen_spc pg)
+        }
+pGen2aGen pg@P_Cy{}
+   = IsE { genfp = gen_fp pg
+         , genrhs = map pCpt2aCpt (gen_rhs pg)
+         , genspc = pCpt2aCpt (gen_spc pg)
+         }
+
+findSign :: String -> String -> Sign
+findSign a b = Sign (findConceptOrONE a) (findConceptOrONE b)
+
+maybeOverGuarded :: Applicative f => (t -> f a) -> Maybe t -> f (Maybe a)
+maybeOverGuarded _ Nothing = pure Nothing
+maybeOverGuarded f (Just x) = Just <$> f x
+
+data TT a  -- (In order of increasing strictness. If you are unsure which to pick: just use MBE, it'll usually work fine)
+ = UNI a a -- find the union of these types, return it.
+ | ISC a a -- find the intersection of these types, return it.
+ | MBE a a -- must be equal: must be (made) of equal type. If these types are comparable, it returns the greatest.
+ | MBG a a -- The first of these types must be the greatest, if so, return it (error otherwise)
+ -- SJC: difference between UNI and MBE
+ -- in general, UNI is less strict than MBE:
+ --   suppose A ≤ C, B ≤ C, and C is the least such concept (e.g. if A≤D and B≤D then C≤D)
+ --   in this case UNI A B will yield C (if both A and B are generalizable), while MBE A B will give an error
+ --   note that in case of A ≤ C, B ≤ C, A ≤ D, B ≤ D (and there is no order between C and D), both will give an error
+ --   the error message, however, should be different:
+ --     for MBE it says that A and B must be of the same type, and suggests adding an order between A and B
+ --     for UNI it says that it cannot decide whether A \/ B is of type C or D, and suggests adding an order between C and D
+ --   In addition, MBE requires that both sides are not generalizable. UNI does not, and simply propagates this property.
+ -- MBG is like MBE, but will only try to generalize the right hand side (when allowed)
+
+deriv' :: (Applicative f)
+       => ((SrcOrTgt, t -> (Expression, (Bool, Bool))), (SrcOrTgt, t -> (Expression, (Bool, Bool))))
+       -> t
+       -> f ((String, Bool), (String, Bool))
+deriv' (a,b) es = let (sourceOrTarget1, (e1, t1)) = resolve es a
+                      (sourceOrTarget2, (e2, t2)) = resolve es b
+                  in pure ((gc sourceOrTarget1 e1, t1), (gc sourceOrTarget2 e2, t2))
+instance Functor TT where
+  fmap f (UNI a b) = UNI (f a) (f b)
+  fmap f (ISC a b) = ISC (f a) (f b)
+  fmap f (MBE a b) = MBE (f a) (f b)
+  fmap f (MBG a b) = MBG (f a) (f b)
+ src/lib/DatabaseDesign/Ampersand/ADL1/Pair.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+module DatabaseDesign.Ampersand.ADL1.Pair
+                    ( Paire,Pairs
+                    , kleenejoin
+                    , srcPaire,trgPaire
+                    , mkPair
+                    , closPair
+                    , clos1
+                    ) 
+where
+   import DatabaseDesign.Ampersand.Basics (Collection(isc,uni),eqCl)
+   import Data.List (nub)
+   import GHC.Exts (sortWith)
+
+   type Pairs = [Paire]
+   srcPaire :: Paire -> String
+   trgPaire :: Paire -> String
+   mkPair :: String -> String -> Paire
+   type Paire = (String,String)
+   mkPair a b = (a,b)
+   srcPaire = fst
+   trgPaire = snd
+
+
+   -- | Operations for representations that act as a Kleene algebra (RA without complement and with the closure operators)
+   -- | A Kleene algebra has two binary operations 'union' and 'kleenejoin', and one function 'closure' (usually written as +, � and * respectively)
+   class KAComputable a where
+     kleenejoin :: a->a->a
+     closPair :: a->a
+     -- TODO: add the 'uni' operator
+   
+   instance (KAComputable a) => KAComputable (Maybe a) where
+     kleenejoin (Just a) (Just b) = Just (kleenejoin a b)
+     kleenejoin _ _ = Nothing
+     closPair (Just p) = Just (closPair p)
+     closPair _ = Nothing
+      
+   instance KAComputable Pairs where
+     kleenejoin a b = merge ((sortWith (trgPaire.head).eqCl trgPaire) a)
+                      ((sortWith (srcPaire.head).eqCl srcPaire) b)
+                where merge (xs:xss) (ys:yss)
+                       | trgPaire (head xs)<srcPaire (head ys) = merge xss (ys:yss)
+                       | trgPaire (head xs)>srcPaire (head ys) = merge (xs:xss) yss
+                       | otherwise = [mkPair (srcPaire x) (trgPaire y) |x<-xs,y<-ys]++ merge xss yss
+                      merge _ _ = []
+     closPair ps = toPairs (clos1 (toList ps))
+      where
+       toPairs :: [(String,String)] -> Pairs
+       toPairs pairs = [mkPair a b | (a,b)<-pairs]
+       toList :: Pairs -> [(String,String)]
+       toList pairs = [(srcPaire p, trgPaire p) | p<-pairs]
+----------------------------------------------------
+--  Warshall's transitive closure algorithm in Haskell:
+----------------------------------------------------
+   clos1 :: (Eq a) => [(a,a)] -> [(a,a)]     -- e.g. a list of pairs
+   clos1 xs
+     = foldl f xs (nub (map fst xs) `isc` nub (map snd xs))
+       where
+        f q x = q `uni` [(a, b') | (a, b) <- q, b == x, (a', b') <- q, a' == x]
+ src/lib/DatabaseDesign/Ampersand/ADL1/Rule.hs view
@@ -0,0 +1,105 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.ADL1.Rule    (
+                consequent, antecedent, rulefromProp, ruleviolations, hasantecedent)
+where
+   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+   import DatabaseDesign.Ampersand.Basics
+   import DatabaseDesign.Ampersand.Core.ParseTree        ( Prop(..))
+   import DatabaseDesign.Ampersand.Classes.Populated              ( Populated(..))
+   import DatabaseDesign.Ampersand.Misc
+
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "ADL1.Rule"
+
+
+   hasantecedent :: Rule -> Bool
+   hasantecedent r
+    = case rrexp r of
+        EEqu{} -> True
+        EImp{} -> True
+        _      -> False
+   antecedent :: Rule -> Expression
+   antecedent r
+    = case rrexp r of
+        EEqu (le,_) -> le
+        EImp (le,_) -> le
+        _           -> fatal 134 $ "erroneous reference to antecedent of rule "++show r
+
+   consequent :: Rule -> Expression
+   consequent r
+    = case rrexp r of
+        EEqu (_,re) -> re
+        EImp (_,re) -> re
+        x           -> x
+
+   ruleviolations :: [A_Gen] -> [Population] -> Rule -> Pairs
+   ruleviolations gens pt r = case rrexp r of
+        EEqu{} -> (cra >- crc) ++ (crc >- cra)
+        EImp{} -> cra >- crc
+        _      -> fullContents gens pt (EDcV (sign (consequent r))) >- crc  --everything not in con
+        where cra = fullContents gens pt (antecedent r)
+              crc = fullContents gens pt (consequent r)
+
+-- rulefromProp specifies a rule that defines property prp of declaration d.
+-- The table of all declarations is provided, in order to generate shorter names if possible.
+   rulefromProp :: Prop -> Declaration -> Rule
+   rulefromProp prp d@Sgn{}
+      = Ru { rrnm  = show prp++" "++name d++"::"++s++"*"++t
+           , rrexp = rExpr
+           , rrfps = origin d
+           , rrmean = AMeaning $ explain True prp
+           , rrmsg = explain False prp
+           , rrviol = Nothing
+           , rrtyp = sign rExpr
+           , rrdcl = Just (prp,d)         -- For traceability: The original property and declaration.
+           , r_env = decpat d             -- For traceability: The name of the pattern. Unknown at this position but it may be changed by the environment.
+           , r_usr = Multiplicity
+           , r_sgl = False
+           , srrel = d{decnm=show prp++name d}
+           }
+          where
+           s = name (source d)
+           t = name (target d)
+           r:: Expression
+           r = EDcD d
+           rExpr = case prp of
+                        Uni-> flp r .:. r .|-. EDcI (target r)
+                        Tot-> EDcI (source r)  .|-. r .:. flp r
+                        Inj-> r .:. flp r .|-. EDcI (source r)
+                        Sur-> EDcI (target r)  .|-. flp r .:. r
+                        Sym-> r .==. flp r
+                        Asy-> flp r ./\. r .|-. EDcI (source r)
+                        Trn-> r .:. r .|-. r
+                        Rfx-> EDcI (source r) .|-. r
+                        Irf-> EDcI (source r) ./\. (EDcV (sign r) .-. r)
+           explain isPositive prop = [ A_Markup English ReST (string2Blocks ReST (
+                                 case prop of
+                                   Sym-> state isPositive English (name d++"["++s++"]") "symmetric"
+                                   Asy-> state isPositive English (name d++"["++s++"]") "antisymmetric"
+                                   Trn-> state isPositive English (name d++"["++s++"]") "transitive"
+                                   Rfx-> state isPositive English (name d++"["++s++"]") "reflexive"
+                                   Irf-> state isPositive English (name d++"["++s++"]") "irreflexive"
+                                   Uni-> state isPositive English (name d++"["++s++"*"++t++"]") "univalent"
+                                   Sur-> state isPositive English (name d++"["++s++"*"++t++"]") "surjective"
+                                   Inj-> state isPositive English (name d++"["++s++"*"++t++"]") "injective"
+                                   Tot-> state isPositive English (name d++"["++s++"*"++t++"]") "total"
+                                   ))
+                          ,   A_Markup Dutch ReST (string2Blocks ReST (
+                                 case prop of
+                                   Sym-> state isPositive Dutch (name d++"["++s++"]") "symmetrisch."
+                                   Asy-> state isPositive Dutch (name d++"["++s++"]") "antisymmetrisch."
+                                   Trn-> state isPositive Dutch (name d++"["++s++"]") "transitief."
+                                   Rfx-> state isPositive Dutch (name d++"["++s++"]") "reflexief."
+                                   Irf-> state isPositive Dutch (name d++"["++s++"]") "irreflexief."
+                                   Uni-> state isPositive Dutch (name d++"["++s++"*"++t++"]") "univalent"
+                                   Sur-> state isPositive Dutch (name d++"["++s++"*"++t++"]") "surjectief"
+                                   Inj-> state isPositive Dutch (name d++"["++s++"*"++t++"]") "injectief"
+                                   Tot-> state isPositive Dutch (name d++"["++s++"*"++t++"]") "totaal"
+                                   ))
+                         ]
+
+           state True  _       left right = left ++ " is " ++ right
+           state False English left right = left ++ " is not " ++ right
+           state False Dutch   left right = left ++ " is niet " ++ right
+
+   rulefromProp _ _ = fatal 252 "Properties can only be set on user-defined declarations."
+ src/lib/DatabaseDesign/Ampersand/Basics.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Basics (module X, Identified(..)) where
+import DatabaseDesign.Ampersand.Basics.Auxiliaries as X
+import DatabaseDesign.Ampersand.Basics.Collection as X
+import DatabaseDesign.Ampersand.Basics.String as X
+import DatabaseDesign.Ampersand.Basics.UTF8 as X
+import DatabaseDesign.Ampersand.Basics.Version as X
+
+
+class Identified a where
+  name :: a->String
+
+ src/lib/DatabaseDesign/Ampersand/Basics/Auxiliaries.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Basics.Auxiliaries
+   ( eqCl 
+   , eqClass
+   , getCycles
+   , combinations
+   , commaEng
+   , commaNL
+   , Flippable(..)
+   )
+  where
+   import Data.List (nub,elemIndex)
+   import Data.Graph (stronglyConnComp, SCC(CyclicSCC))
+   import Data.Maybe (fromMaybe)
+
+   -- | The 'eqClass' function takes an equality test function and a list and returns a list of lists such
+   -- that each sublist in the result contains only equal elements, and all equal elements are in 
+   -- the same sublist.  For example,
+   --
+   -- > eqClass "Mississippi" = ["M","iiii","ssss","pp"]
+   --
+   eqClass :: (a -> a -> Bool) -> [a] -> [[a]]
+   eqClass _ [] = []
+   eqClass f (x:xs) = (x:[e |e<-xs, f x e]) : eqClass f [e |e<-xs, not (f x e)]
+
+   -- | eqCl is a very useful function for gathering things that are equal wrt some criterion f.
+   --   For instance, if you want to have persons with the same name:
+   --    'eqCl name persons' produces a list,in which each element is a list of persons with the same name.
+   eqCl :: Eq b => (a -> b) -> [a] -> [[a]]
+   eqCl _ [] = []
+   eqCl f (x:xs) = (x:[e |e<-xs, f x==f e]) : eqCl f [e |e<-xs, f x/=f e]
+
+   -- | getCycles returns a list of cycles in the edges list (each edge is a pair of a from-vertex
+   --   and a list of to-vertices)
+   getCycles :: Eq a => [(a, [a])] -> [[a]]
+   getCycles edges =
+     let allVertices = nub . concat $ [ from : to | (from, to) <- edges ] 
+         keyFor v = fromMaybe (error "FATAL") $ elemIndex v allVertices
+         graphEdges = [ (v, keyFor v , map keyFor vs)  | (v, vs) <- edges ]
+     in  [ vs | CyclicSCC vs <- stronglyConnComp graphEdges ]
+
+-- The following function can be used to determine how much of a set of alternative expression is already determined
+   -- | The 'combinations' function returns all possible combinations of lists of list.
+   -- For example,
+   --
+   -- > combinations [[1,2,3],[10,20],[4]] == [[1,10,4],[1,20,4],[2,10,4],[2,20,4],[3,10,4],[3,20,4]]
+   combinations :: [[a]] -> [[a]]
+   combinations []       = [[]]
+   combinations (es:ess) = [ x:xs | x<-es, xs<-combinations ess]
+                              
+   commaEng :: String -> [String] -> String
+   commaEng str [a,b,c] = a++", "++b++", "++str++" "++c
+   commaEng str [a,b]   = a++" "++str++" "++b
+   commaEng _   [a]     = a
+   commaEng str (a:as)  = a++", "++commaEng str as
+   commaEng _   []      = ""
+
+   commaNL :: String -> [String] -> String
+   commaNL str [a,b]  = a++" "++str++" "++b
+   commaNL  _  [a]    = a
+   commaNL str (a:as) = a++", "++commaNL str as
+   commaNL  _  []     = ""
+
+   
+   class Flippable a where
+     flp :: a -> a
+
+ src/lib/DatabaseDesign/Ampersand/Basics/BuildInfo_Generated.hs view
@@ -0,0 +1,15 @@+module DatabaseDesign.Ampersand.Basics.BuildInfo_Generated (cabalVersionStr, svnRevisionStr, buildTimeStr) where
+
+-- This module is generated automatically by Setup.hs before building. Do not edit!
+
+{-# NOINLINE cabalVersionStr #-}
+cabalVersionStr :: String
+cabalVersionStr = "3.0.0"
+
+{-# NOINLINE svnRevisionStr #-}
+svnRevisionStr :: String
+svnRevisionStr = "1250M"
+
+{-# NOINLINE buildTimeStr #-}
+buildTimeStr :: String
+buildTimeStr = "16-Dec-13 22:29:21 UTC"
+ src/lib/DatabaseDesign/Ampersand/Basics/Collection.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Basics.Collection
+  (  Collection ( eleM
+                , uni
+                , isc
+                ,(>-)
+                ,empty
+                ,elems)
+  )where
+   ----------------------------------------------
+   ---- Collection of type a --------------------
+   ----------------------------------------------
+   infixl 5  >-
+
+   class Collection a where      -- TODO Vervangen door efficient algorithme: Data.Set
+    eleM :: Eq b => b -> a b -> Bool  
+    uni, isc :: Eq b => a b -> a b -> a b  
+    (>-) :: Eq b => a b -> a b -> a b
+    empty :: Eq b => a b
+    elems :: Eq b => a b -> [b]
+
+   instance Collection [] where
+    eleM         = elem
+    xs `uni` ys  = xs++(ys>-xs)
+    xs `isc` ys  = [y | y<-ys, y `elem` xs]
+    xs >- ys     = [x | x<-xs, x `notElem` ys]
+    empty        = []
+    elems        = id
+ src/lib/DatabaseDesign/Ampersand/Basics/String.hs view
@@ -0,0 +1,29 @@+  {-# OPTIONS_GHC -Wall #-}
+  -- | This module contains some common String funcions
+  module DatabaseDesign.Ampersand.Basics.String
+   (unCap,upCap,escapeNonAlphaNum)
+  where
+   import Data.Char 
+
+   -- | Converts the first character of a string to lowercase, with the exception that there is a second character, which is uppercase. 
+   -- uncap "AbcDe" == "abcDe"
+   -- uncap "ABcDE" == "ABcDE"  
+   unCap :: String -> String
+   unCap [] = []
+   unCap [h] = [toLower h]
+   unCap (h:h':t) | isUpper h' = h:h':t
+                  | otherwise  = toLower h:h':t
+   -- | Converts the first character of a string to uppercase
+   upCap :: String -> String
+   upCap [] = []  
+   upCap (h:t) = toUpper h:t
+
+   
+   -- | escape anything except regular characters and digits to _<character code>
+   -- e.g. escapeNonAlphaNum "a_é" = "a_95_233"
+   escapeNonAlphaNum :: String -> String
+   escapeNonAlphaNum = concatMap escapeNonAlphaNumChar
+    where escapeNonAlphaNumChar c 
+            | isAlphaNum c && isAscii c = [c]
+            | otherwise                 = '_' : show (ord c)
+
+ src/lib/DatabaseDesign/Ampersand/Basics/UTF8.hs view
@@ -0,0 +1,79 @@+{-
+Copyright (C) 2010 John MacFarlane <jgm@berkeley.edu>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+-}
+
+{- |
+   Module      : Text.Pandoc.UTF8
+   Copyright   : Copyright (C) 2010 John MacFarlane
+   License     : GNU GPL, version 2 or above 
+
+   Maintainer  : John MacFarlane <jgm@berkeley.edu>
+   Stability   : alpha
+   Portability : portable
+
+UTF-8 aware string IO functions that will work with GHC 6.10, 6.12, or 7.
+-}
+module DatabaseDesign.Ampersand.Basics.UTF8
+           ( readFile
+            , writeFile
+            , getContents
+            , putStr
+            , putStrLn
+            , hGetContents
+            , hPutStr
+            , hPutStrLn
+            )
+
+where
+import Codec.Binary.UTF8.String (encodeString)
+import qualified Data.ByteString as B hiding (putStrLn)
+import qualified Data.ByteString.Char8 as C (putStrLn)
+import Data.ByteString.UTF8 (toString, fromString)
+import Prelude hiding (readFile, writeFile, getContents, putStr, putStrLn)
+import System.IO (Handle)
+import Control.Monad (liftM)
+
+bom :: B.ByteString
+bom = B.pack [0xEF, 0xBB, 0xBF]
+
+stripBOM :: B.ByteString -> B.ByteString
+stripBOM s | bom `B.isPrefixOf` s = B.drop 3 s
+stripBOM s = s
+
+readFile :: FilePath -> IO String
+readFile = liftM (toString . stripBOM) . B.readFile . encodeString
+
+writeFile :: FilePath -> String -> IO ()
+writeFile f = B.writeFile (encodeString f) . fromString
+
+getContents :: IO String
+getContents = liftM (toString . stripBOM) B.getContents
+
+putStr :: String -> IO ()
+putStr = B.putStr . fromString
+
+putStrLn :: String -> IO ()
+putStrLn = C.putStrLn . fromString
+
+hGetContents :: Handle -> IO String
+hGetContents h = liftM (toString . stripBOM) (B.hGetContents h)
+
+hPutStr :: Handle -> String -> IO ()
+hPutStr h = B.hPutStr h . fromString
+
+hPutStrLn :: Handle -> String -> IO ()
+hPutStrLn h s = hPutStr h (s ++ "\n")
+ src/lib/DatabaseDesign/Ampersand/Basics/Version.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -Wall #-}+-- | This module contains Version of Ampersand+module DatabaseDesign.Ampersand.Basics.Version (ampersandVersionStr, ampersandVersionWithoutBuildTimeStr, fatalMsg) where++import DatabaseDesign.Ampersand.Basics.BuildInfo_Generated++-- | a function to create error message in a structured way, containing the version of Ampersand. +--   It throws an error, showing a (module)name and a number. This makes debugging pretty easy. +fatalMsg :: String -> Int -> String -> a+fatalMsg haskellModuleName lineNr msg+ = error ("!fatal "++show lineNr++" (module "++haskellModuleName++") "++ampersandVersionWithoutBuildTimeStr++"\n  "+++            let maxLen = 1500 -- This trick is to make sure the process is terminated after the error. +                              -- If the string is too long, it seems that the sentinel `hangs`.+                              -- But what is too long???+            in case drop maxLen msg of+                [] -> msg+                _  -> take maxLen msg ++"\n<The rest of error message has been cut off.>"+           )++-- | String, containing the Ampersand version, including the build timestamp.+ampersandVersionStr :: String+ampersandVersionStr = ampersandVersionWithoutBuildTimeStr ++", build time: "++buildTimeStr++-- | String, containing the Ampersand version+ampersandVersionWithoutBuildTimeStr :: String+ampersandVersionWithoutBuildTimeStr = "Ampersand v"++cabalVersionStr++"."++svnRevisionStr+{- +   #1.#2.#3.#4 : #1 major version; #2 student release version; #3 production fix version (normally 0 ); +   #4 SVN revision number: +      - may be a range separated by ':' if the working copy contains mixed revisions (e.g. "163:165")+      - ends with an 'M' if the working copy was modified (e.g. "163M")+      - for other (rare) values, see the output of the command 'svnversion --help' +-}
+ src/lib/DatabaseDesign/Ampersand/Classes.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Classes (module X) where
+import DatabaseDesign.Ampersand.Classes.Populated as X
+       (Populated(..),atomsOf)
+import DatabaseDesign.Ampersand.Classes.ConceptStructure as X
+       (ConceptStructure(..))
+import DatabaseDesign.Ampersand.Classes.Object as X (Object(..))
+import DatabaseDesign.Ampersand.Classes.Relational as X
+       (Relational(..))
+import DatabaseDesign.Ampersand.Classes.ViewPoint as X
+       (Language(..), ProcessStructure(..))
+ src/lib/DatabaseDesign/Ampersand/Classes/ConceptStructure.hs view
@@ -0,0 +1,147 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE FlexibleInstances #-}
+module DatabaseDesign.Ampersand.Classes.ConceptStructure          (ConceptStructure(..)
+                                                                   )
+where
+   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree       
+   import DatabaseDesign.Ampersand.Basics
+   import Data.List
+   import Data.Maybe
+   import DatabaseDesign.Ampersand.ADL1.Expression
+   import Prelude hiding (Ordering(..))
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Classes.ConceptStructure"
+
+   class ConceptStructure a where
+    concs ::    a -> [A_Concept]       -- ^ the set of all concepts used in data structure a
+    declsUsedIn :: a -> [Declaration]        -- ^ the set of all declaratons used within data structure a. `used within` means that there is a relation that refers to that declaration.
+    declsUsedIn a = [ d | EDcD d@Sgn{}<-(nub.concatMap primitives.expressionsIn) a]
+    relsUsedIn :: a -> [Declaration]        -- ^ the set of all declaratons used within data structure a. `used within` means that there is a relation that refers to that declaration.
+    relsUsedIn a = [ prim2dcl e | e<-nub ((concatMap primitives.expressionsIn) a++(map EDcI . concs) a), not (isMp1 e) ]
+      where prim2dcl expr =
+             case expr of
+               EDcD d@Sgn{} -> d
+               EDcD{}       -> fatal 23 "invalid declaration in EDcD{}" 
+               EDcI c       -> Isn c
+               EDcV sgn     -> Vs sgn
+               EMp1{}  -> fatal 25 "EMp1 should be filtered out from primitives. use `filter (not isMp1)`"
+               _       -> fatal 26 "prim2dcl is not supposed to be called on a non-primitive expression."
+    expressionsIn :: a -> [Expression] -- ^The set of all expressions within data structure a 
+    mp1Exprs :: a -> [Expression]     -- ^ the set of all EMp1 expressions within data structure a (needed to get the atoms of these relations into the populationtable)
+    mp1Exprs = filter isMp1.nub.concatMap primitives.expressionsIn
+
+   instance (ConceptStructure a,ConceptStructure b) => ConceptStructure (a, b)  where
+    concs    (a,b) = concs a `uni` concs b
+    expressionsIn (a,b) = expressionsIn a `uni` expressionsIn b
+
+   instance ConceptStructure a => ConceptStructure (Maybe a) where
+    concs    ma = maybe [] concs ma
+    expressionsIn ma = maybe [] expressionsIn ma
+ 
+   instance ConceptStructure a => ConceptStructure [a] where
+    concs     = nub . concatMap concs
+    expressionsIn = foldr ((uni) . expressionsIn) [] 
+    
+   instance ConceptStructure A_Context where
+    concs     c =       concs ( ctxds c ++ concatMap ptdcs (ctxpats c)  ++ concatMap prcDcls (ctxprocs c) ) 
+                  `uni` concs ( ctxgs c ++ concatMap ptgns (ctxpats c)  ++ concatMap prcGens (ctxprocs c) )
+                  `uni` [ONE]
+    expressionsIn c = foldr (uni) []
+                      [ (expressionsIn.ctxpats) c
+                      , (expressionsIn.ctxprocs) c
+                      , (expressionsIn.ctxifcs) c
+                      , (expressionsIn.ctxrs) c
+                      , (expressionsIn.ctxks) c
+                      , (expressionsIn.ctxvs) c
+                      , (expressionsIn.ctxsql) c
+                      , (expressionsIn.ctxphp) c
+                      ]
+
+   instance ConceptStructure IdentityDef where
+    concs       identity   = [idCpt identity] `uni` concs [objDef | IdentityExp objDef <- identityAts identity]
+    expressionsIn identity = expressionsIn             [objDef | IdentityExp objDef <- identityAts identity]
+
+   instance ConceptStructure ViewDef where
+    concs       vd = [vdcpt vd] `uni` concs [objDef | ViewExp objDef <- vdats vd]
+    expressionsIn vd = expressionsIn        [objDef | ViewExp objDef <- vdats vd]
+
+   instance ConceptStructure Expression where
+    concs (EDcI c    ) = [c]
+    concs (EEps i sgn) = nub (i:concs sgn)
+    concs (EDcV   sgn) = concs sgn
+    concs (EMp1 _ c  ) = [c]
+    concs e            = foldrMapExpression uni concs [] e
+    expressionsIn e = [e]
+
+
+   instance ConceptStructure A_Concept where
+    concs   c     = [c]
+    expressionsIn _ = []
+
+   instance ConceptStructure Sign where
+    concs (Sign s t) = nub [s,t]
+    expressionsIn _  = []
+
+   instance ConceptStructure ObjectDef where
+    concs     obj = [target (objctx obj)] `uni` concs (objmsub obj)
+    expressionsIn obj = foldr (uni) []
+                       [ (expressionsIn.objctx) obj
+                       , (expressionsIn.objmsub) obj
+                       ]
+
+   -- Note that these functions are not recursive in the case of InterfaceRefs (which is of course obvious from their types)
+   instance ConceptStructure SubInterface where
+    concs (Box _ objs)         = concs objs 
+    concs (InterfaceRef _)   = [] 
+    expressionsIn (Box _ objs)       = expressionsIn objs 
+    expressionsIn (InterfaceRef _) = [] 
+          
+   instance ConceptStructure Pattern where
+    concs       p = concs (ptgns p)   `uni` concs (ptdcs p)   `uni` concs (ptrls p)    `uni` concs (ptids p)
+    expressionsIn p = foldr (uni) []
+                       [ (expressionsIn.ptrls) p
+                       , (expressionsIn.ptids) p
+                       , (expressionsIn.ptvds) p
+                       ]
+
+   instance ConceptStructure Process where
+    concs     p = concs (prcGens p) `uni` concs (prcDcls p) `uni` concs (prcRules p) `uni` concs (prcIds p)
+    expressionsIn p = foldr (uni) []
+                       [ (expressionsIn.prcRules) p
+                       , (expressionsIn.prcIds) p
+                       , (expressionsIn.prcVds) p
+                       ]
+
+   instance ConceptStructure Interface where
+    concs       ifc = concs       (ifcObj ifc)
+    expressionsIn ifc = foldr (uni) []
+                       [ (expressionsIn.ifcObj) ifc
+                       , (expressionsIn.ifcParams) ifc
+                       ]
+
+   instance ConceptStructure Declaration where
+    concs         d = concs (sign d)
+    expressionsIn _ = fatal 148 "expressionsIn not allowed on Declaration"
+
+   instance ConceptStructure Rule where
+    concs r   = concs (rrexp r) ++ concs (rrviol r)
+    expressionsIn r = foldr (uni) []
+                     [ (expressionsIn.rrexp ) r
+                     , (expressionsIn.rrviol) r
+                     ]
+   
+   instance ConceptStructure (PairView Expression) where
+    concs         (PairView ps) = concs         ps
+    expressionsIn (PairView ps) = expressionsIn ps
+     
+   instance ConceptStructure (PairViewSegment Expression) where
+    concs       (PairViewText _)  = []
+    concs       (PairViewExp _ x) = concs x
+    expressionsIn    (PairViewText _)  = []
+    expressionsIn    (PairViewExp _ x) = expressionsIn x
+     
+   instance ConceptStructure A_Gen where
+    concs g@Isa{}  = nub [gengen g,genspc g]  
+    concs g@IsE{}  = nub (genspc g: genrhs g)
+    expressionsIn _ = fatal 160 "expressionsIn not allowed on A_Gen"
+
+ src/lib/DatabaseDesign/Ampersand/Classes/Object.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Classes.Object
+        (Object(..)      )
+where
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+import DatabaseDesign.Ampersand.Basics (fatalMsg)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Classes.Object"
+
+class Object a where
+ concept :: a -> A_Concept                 -- the type of the object
+ attributes :: a -> [ObjectDef]          -- the objects defined within the object    
+ contextOf :: a -> Expression -- the context expression
+ foldedattributes ::  a -> [Expression] --the attributes of obj as a list of expressions with source = concept obj
+ foldedattributes obj 
+      = contextOf obj:[contextOf obj .:. x |xs<-map foldedattributes (attributes obj),x<-xs]
+
+instance Object A_Context where
+ concept _      = fatal 29 "this used to be 'Anything' but that has become history in ticket #104."
+ attributes c   = [ifcObj s | s<-ctxifcs c]
+ contextOf  _   = fatal 38 "Cannot evaluate the context expression of the current context (yet)"
+ 
+instance Object ObjectDef where
+ concept obj = target (objctx obj)
+ attributes  = objAts
+ contextOf   = objctx
+ src/lib/DatabaseDesign/Ampersand/Classes/Populated.hs view
@@ -0,0 +1,124 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Classes.Populated                 (Populated(..),atomsOf)
+where
+   import DatabaseDesign.Ampersand.ADL1.Pair                       (kleenejoin,mkPair,closPair,srcPaire,trgPaire)
+   import DatabaseDesign.Ampersand.ADL1.Expression                 (notCpl)
+   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+   import DatabaseDesign.Ampersand.Basics                     (Collection (..),fatalMsg, Identified(..))   
+   import Data.List (nub)
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Classes.Populated"
+
+   
+   class Populated a where
+    -- | this function returns the pairs as content of a specific a, given a list of populations. 
+    --   The list of populations should contain all user-defined populations. 
+    fullContents :: [A_Gen] -> [Population] -> a -> Pairs
+   
+   -- | 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 126 "Asking for the value of the universal singleton"
+      PlainConcept{}
+          -> nub$ [srcPaire p | PRelPopu dcl ps   <- pt, p <- ps, source dcl `elem` c:smallerConcepts gens c]
+                ++[trgPaire p | PRelPopu dcl ps   <- pt, p <- ps, target dcl `elem` c:smallerConcepts gens c]
+                ++[a          | PCptPopu cpt atms <- pt, a <- atms, cpt      `elem` c:smallerConcepts gens c]
+      
+   instance Populated Declaration where
+    fullContents gens pt dcl
+      = case dcl of
+         Isn c  -> [ mkPair a a   | a  <-atomsOf gens pt c]
+         Vs sgn -> [ mkPair sa ta | sa <-atomsOf gens pt (source sgn)
+                                  , ta <-atomsOf gens pt (target sgn)]
+         Sgn{} -> if decISA dcl
+                  then [ mkPair a a | a <-atomsOf gens pt (source dcl)] 
+                  else concatMap  popps (filter (isTheDecl dcl) pt)
+     where isTheDecl d pop =
+             case pop of
+               PRelPopu{}  -> d == popdcl pop
+               PCptPopu{}  -> False
+
+
+   instance Populated Expression where
+    fullContents gens pt = contents
+     where
+      contents expr
+       = case expr of
+            EEqu (l,r) -> contents ((l .|-. r) ./\. (r .|-. l))
+            EImp (l,r) -> contents (notCpl l .\/. r)
+            EUni (l,r) -> contents l `uni` contents r
+            EIsc (l,r) -> contents l `isc` contents r
+            EDif (l,r) -> contents l >- contents r
+            -- The left residual l/r is defined by: for all x,y:  y(l/r)x  <=>  for all z in X, x l z implies y r z.
+            ELrs (l,r) -> [(y,x) | x <- case source l of
+                                          sl@PlainConcept{} -> atomsOf gens pt sl
+                                          sl     -> fatal 68 ("source l should be PlainConcept instead of "++show sl++".")
+                                 , y <- case source r of
+                                          sr@PlainConcept{} -> atomsOf gens pt sr
+                                          sr     -> fatal 71 ("source r should be PlainConcept instead of "++show sr++".")
+                            --   Derivation:
+                            --   , and      [(x,z) `elem` contents l <- (y,z) `elem` contents r          |z<- atomsOf gens pt (target l `join` target r)]
+                            --   , and      [(x,z) `elem` contents l || (y,z) `notElem` contents r       |z<- atomsOf gens pt (target l `join` target r)]
+                            --   , (not.or) [not ((x,z) `elem` contents l || (y,z) `notElem` contents r) |z<- atomsOf gens pt (target l `join` target r)]
+                            --   , (not.or) [     (x,z) `notElem` contents l && (y,z) `elem` contents r  |z<- atomsOf gens pt (target l `join` target r)]
+                            --   , (not.null) [ () |z<- atomsOf gens pt (target l `join` target r), (x,z) `notElem` contents l, (y,z) `elem` contents r]
+                                 , (not.null) [ () |z<- atomsOf gens pt (target l) `uni` atomsOf gens pt (target r), (x,z) `notElem` contents l, (y,z) `elem` contents r]
+                                 ]   -- equals contents (ERrs (flp r, flp 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) -> [(x,y) | x <- case target l of
+                                          tl@PlainConcept{} -> atomsOf gens pt tl
+                                          tl     -> fatal 83 ("target l should be PlainConcept instead of "++show tl++".")
+                                 , y <- case target r of
+                                          tr@PlainConcept{} -> atomsOf gens pt tr
+                                          tr     -> fatal 86 ("target r should be PlainConcept instead of "++show tr++".")
+                            --   Derivation:
+                            --     and      [(z,x) `elem` contents l    -> (z,y) `elem` contents r       |z<- atomsOf gens pt (source l `join` source r)]
+                            --     and      [(z,x) `notElem` contents l || (z,y) `elem` contents r       |z<- atomsOf gens pt (source l `join` source r)]
+                            --     (not.or) [not ((z,x) `notElem` contents l || (z,y) `elem` contents r) |z<- atomsOf gens pt (source l `join` source r)]
+                            --     (not.or) [     (z,x) `elem` contents l && (z,y) `notElem` contents r  |z<- atomsOf gens pt (source l `join` source r)]
+                            --     (not.null) [ () |z<- atomsOf gens pt (source l `join` source r), (z,x) `elem` contents l, (z,y) `notElem` contents r]
+                                 , (not.null) [ () |z<- atomsOf gens pt (source l) `uni` atomsOf gens pt (source r), (z,x) `elem` contents l, (z,y) `notElem` contents r]
+                                 ]   -- equals contents (ELrs (flp r, flp l))
+            ERad (l,r) -> [(x,y) | x <- case source l of
+                                          sl@PlainConcept{} -> atomsOf gens pt sl
+                                          sl     -> fatal 97 ("source l should be PlainConcept instead of "++show sl++".")
+                                 , y <- case target r of
+                                          tr@PlainConcept{} -> atomsOf gens pt tr
+                                          tr     -> fatal 100 ("target r should be PlainConcept instead of "++show tr++".")
+                                 , and [(x,z) `elem` contents l || (z,y) `elem` contents r |z<- atomsOf gens pt (target l) `uni` atomsOf gens pt (source r)]
+                                 ]
+            EPrd (l,r) -> [ (a,b) | a <- atomsOf gens pt (source l), b <- atomsOf gens pt (target r) ]
+            ECps (l,r) -> contents l `kleenejoin` contents r
+            EKl0 e     -> if source e == target e --see #166
+                          then closPair (contents e `uni` contents (EDcI (source e)))
+                          else fatal 69 ("source and target of "++show e++show (sign e)++ " are not equal.")
+            EKl1 e     -> closPair (contents e)
+            EFlp e     -> [(b,a) | (a,b)<-contents e]
+            ECpl e     -> [apair | apair <-[ mkPair x y | x<-atomsOf gens pt (source e), y<-atomsOf gens pt (target e)]
+                                 , apair `notElem` contents e  ]
+            EBrk e     -> contents e
+            EDcD dcl   -> fullContents gens pt dcl
+            EDcI c     -> [mkPair a a | a <- atomsOf gens pt c]
+            EEps i _   -> [mkPair a a | a <- atomsOf gens pt i]
+            EDcV sgn   -> [mkPair s t | s <- atomsOf gens pt (source sgn), t <- atomsOf gens pt (target sgn) ]
+            EMp1 a c   -> if name c=="SESSION" then [fatal 111 "cannot produce the SESSION atom"] else [mkPair a a] -- prevent populating SESSION
+
+{- Derivation of contents (ERrs (l,r)):
+Let cL = contents l
+    cR = contents r
+  contents (ERrs (l,r))
+= [(x,y) | x<-contents (target l), y<-contents (target r)
+         ,      and [    (z,x) `notElem` cL || (z,y) `elem` cR  | z<-contents (source l)] ]
+= [(x,y) | x<-contents (target l), y<-contents (target r)
+         , not ( or [not((z,x) `notElem` cL || (z,y) `elem` cR) | z<-contents (source l)])]
+= [(x,y) | x<-contents (target l), y<-contents (target r)
+         , not ( or [    (z,x)  `elem` cL && (z,y) `notElem` cR | z<-contents (source l)])]
+= [(x,y) | x<-contents (target l), y<-contents (target r)
+         , null [ () | z<-contents (source l), (z,x)  `elem` cL && (z,y) `notElem` cR]]
+= [(x,y) | x<-contents (target l), y<-contents (target r)
+         , null [ () | (z,x') <- cL, x==x', (z,y) `notElem` cR ]]
+-}
+ src/lib/DatabaseDesign/Ampersand/Classes/Relational.hs view
@@ -0,0 +1,212 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Classes.Relational 
+   (Relational(..)
+   ) where
+
+import Data.Maybe
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+import DatabaseDesign.Ampersand.Core.ParseTree       (Prop(..))
+import DatabaseDesign.Ampersand.ADL1.Expression
+import DatabaseDesign.Ampersand.Basics
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Classes.Relational"
+
+class Association r => Relational r where
+    multiplicities :: r -> [Prop]
+    isProp :: r -> Bool  -- > tells whether the argument is a property
+    isImin :: r -> Bool  -- > tells whether the argument is equivalent to I-
+    isTrue :: r -> Bool  -- > tells whether the argument is equivalent to V
+    isFalse :: r -> Bool  -- > tells whether the argument is equivalent to V-
+    isFunction :: r -> Bool     
+    isFunction r   = null ([Uni,Tot]>-multiplicities r)
+    isTot :: r -> Bool  -- 
+    isTot r = Tot `elem` multiplicities r
+    isUni :: r -> Bool  -- 
+    isUni r = Uni `elem` multiplicities r
+    isSur :: r -> Bool  -- 
+    isSur r = Sur `elem` multiplicities r
+    isInj :: r -> Bool  -- 
+    isInj r = Inj `elem` multiplicities r
+    isRfx :: r -> Bool  -- 
+    isRfx r = Rfx `elem` multiplicities r
+    isIrf :: r -> Bool  -- 
+    isIrf r = Irf `elem` multiplicities r
+    isTrn :: r -> Bool  -- 
+    isTrn r = Trn `elem` multiplicities r
+    isSym :: r -> Bool  -- 
+    isSym r = Sym `elem` multiplicities r
+    isAsy :: r -> Bool  -- 
+    isAsy r = Asy `elem` multiplicities r
+    isIdent :: r -> Bool  -- > tells whether the argument is equivalent to I
+    isEpsilon :: r -> Bool  -- > tells whether the argument is equivalent to I
+
+--instance Relational Relation where
+--    multiplicities rel 
+--      = case rel of
+--           Rel{}               -> multiplicities (reldcl rel)
+--           V {}                -> [Tot]
+--                                ++[Sur]
+--                                ++[Inj | isSingleton (source rel)]
+--                                ++[Uni | isSingleton (target rel)]
+--                                ++[Asy | isEndo rel, isSingleton (source rel)]
+--                                ++[Sym | isEndo rel]
+--                                ++[Rfx | isEndo rel]
+--                                ++[Trn | isEndo rel]
+--           I{}                 -> [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx]
+--    isProp rel = case rel of
+--           Rel{}               -> null ([Asy,Sym]>-multiplicities (reldcl rel))
+--           V{}                 -> isEndo rel && isSingleton (source rel)
+--           I{}                 -> True
+--    isImin rel  = isImin (makeDeclaration rel)   -- > tells whether the argument is equivalent to I-
+--    isTrue rel = case rel of
+--           Rel{}               -> False
+--           V{}                 -> True
+--           I{}                 -> False
+--    isFalse _   = False
+--    isIdent rel = case rel of       -- > tells whether the argument is equivalent to I
+--                   Rel{} -> False
+--                   V{}   -> isEndo rel && isSingleton (source rel)
+--                   I{}   -> True
+
+instance Relational Declaration where
+    multiplicities d = case d of
+           Sgn {}       -> case decprps_calc d of
+                             Nothing -> decprps d
+                             Just ps -> ps 
+           Isn{}        -> [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx]
+           Vs{}         -> [Tot,Sur]
+    isProp d = case d of         -- > tells whether the argument is a property.
+           Sgn {}       -> null ([Asy,Sym]>-multiplicities d)
+           Isn{}        -> True
+           Vs{}         -> isEndo (sign d) && isSingleton (source d)
+    isImin _ = False  -- LET OP: Dit kan natuurlijk niet goed zijn, maar is gedetecteerd bij revision 913, toen straffeloos de Iscompl{} kon worden verwijderd.
+    isTrue d = case d of 
+           Vs{}         -> True
+           _            -> False
+    isFalse _ = False
+    isIdent d = case d of
+                 Isn{} -> True   -- > tells whether the argument is equivalent to I
+                 _     -> False
+    isEpsilon _ = False
+
+isSingleton :: A_Concept -> Bool
+isSingleton ONE = True
+isSingleton _   = False
+
+-- The function "multiplicities" does not only provide the multiplicities provided by the Ampersand user,
+-- but tries to derive the most obvious multiplicity constraints as well. The more multiplicity constraints are known,
+-- the better the data structure that is derived.
+-- Not every constraint that can be proven is obtained by this function. This does not hurt Ampersand.
+instance Relational Expression where        -- TODO: see if we can find more multiplicity constraints...
+ multiplicities expr = case expr of
+     EDcD dcl   -> multiplicities dcl
+     EDcI{}     -> [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx]
+     EEps a sgn -> [Tot | a == source sgn]++[Sur | a == target sgn] ++ [Uni,Inj]
+     EDcV sgn   -> [Tot]
+                 ++[Sur]
+                 ++[Inj | isSingleton (source sgn)]
+                 ++[Uni | isSingleton (target sgn)]
+                 ++[Asy | isEndo sgn, isSingleton (source sgn)]
+                 ++[Sym | isEndo sgn]
+                 ++[Rfx | isEndo sgn]
+                 ++[Trn | isEndo sgn]
+     EBrk f     -> multiplicities f
+     ECps (l,r) -> [m | m<-multiplicities l `isc` multiplicities r, m `elem` [Uni,Tot,Inj,Sur]] -- endo properties can be used and deduced by and from rules: many rules are multiplicities (TODO)
+     EPrd (l,r) -> [Tot | isTot l]++[Sur | isSur r]++[Rfx | isRfx l&&isRfx r]++[Trn]
+     EKl0 e'    -> [Rfx,Trn] `uni` (multiplicities e'>-[Uni,Inj])
+     EKl1 e'    -> [    Trn] `uni` (multiplicities e'>-[Uni,Inj])
+     ECpl e'    -> [p |p<-multiplicities e', p==Sym]
+     EFlp e'    -> [fromMaybe m $ lookup m [(Uni,Inj),(Inj,Uni),(Sur,Tot),(Tot,Sur)] | m <- multiplicities e'] -- switch Uni<->Inj and Sur<->Tot, keeping the others the same
+     EMp1{}     -> [Uni,Inj,Sym,Asy,Trn]
+     _          -> []
+
+ -- |  isTrue e == True   means that e is true, i.e. the population of e is (source e * target e).
+ --    isTrue e == False  does not mean anything.
+ --    the function isTrue is meant to produce a quick answer, without any form of theorem proving.
+ isTrue expr
+  = case expr of
+     EEqu (l,r) -> l == r
+     EImp (l,_) -> isTrue l
+     EIsc (l,r) -> isTrue l && isTrue r
+     EUni (l,r) -> isTrue l || isTrue r 
+     EDif (l,r) -> isTrue l && isFalse r
+     ECps (l,r) | null ([Uni,Tot]>-multiplicities l) -> isTrue r
+                | null ([Sur,Inj]>-multiplicities r) -> isTrue l
+                | otherwise                          -> isTrue l && isTrue r
+     EPrd (l,r) -> isTrue l && isTrue r || isTot l && isSur r || isRfx l && isRfx r
+     EKl0 e     -> isTrue e
+     EKl1 e     -> isTrue e
+     EFlp e     -> isTrue e
+     ECpl e     -> isFalse e
+     EDcD{}     -> False
+     EDcI c     -> isSingleton c
+     EEps i _   -> isSingleton i
+     EDcV{}     -> True
+     EBrk e     -> isTrue e
+     _          -> False  -- TODO: find richer answers for ERrs, ELrs, ERad, and EMp1
+
+ -- |  isFalse e == True   means that e is false, i.e. the population of e is empty.
+ --    isFalse e == False  does not mean anything.
+ --    the function isFalse is meant to produce a quick answer, without any form of theorem proving.
+ isFalse expr
+  = case expr of
+     EEqu (l,r) -> l == notCpl r
+     EImp (_,r) -> isFalse r
+     EIsc (l,r) -> isFalse r || isFalse l
+     EUni (l,r) -> isFalse r && isFalse l
+     EDif (l,r) -> isFalse l || isTrue r
+     ECps (l,r) -> isFalse r || isFalse l
+     EPrd (l,r) -> isFalse r || isFalse l
+     EKl0 e     -> isFalse e
+     EKl1 e     -> isFalse e
+     EFlp e     -> isFalse e
+     ECpl e     -> isTrue e
+     EDcD{}     -> False
+     EDcI{}     -> False
+     EEps{}     -> False
+     EDcV{}     -> False
+     EBrk e     -> isFalse e
+     _          -> False  -- TODO: find richer answers for ERrs, ELrs, and ERad
+
+ isProp expr = null ([Asy,Sym]>-multiplicities expr)
+
+ -- |  The function isIdent tries to establish whether an expression is an identity relation.
+ --    It does a little bit more than just test on ERel I _.
+ --    If it returns False, this must be interpreted as: the expression is definitely not I, an may not be equal to I as far as the computer can tell on face value. 
+ isIdent expr = case expr of
+     EEqu (l,r) -> isIdent (EIsc (EImp (l,r), EImp (r,l)))    -- TODO: maybe derive something better?
+     EImp (l,r) -> isIdent (EUni (ECpl l, r))                     -- TODO: maybe derive something better?
+     EIsc (l,r) -> isIdent l && isIdent r
+     EUni (l,r) -> isIdent l && isIdent r
+     EDif (l,r) -> isIdent l && isFalse r
+     ECps (l,r) -> isIdent l && isIdent r
+     EKl0 e     -> isIdent e || isFalse e
+     EKl1 e     -> isIdent e
+     ECpl e     -> isImin e
+     EDcD{}     -> False
+     EDcI{}     -> True
+     EEps i sgn -> if isEndo sgn && i==source expr then fatal 189 (show expr++" is endo") else
+                   False
+     EDcV sgn   -> isEndo sgn && isSingleton (source sgn)
+     EBrk f     -> isIdent f
+     EFlp f     -> isIdent f
+     _          -> False  -- TODO: find richer answers for ERrs, ELrs, EPrd, and ERad
+ isEpsilon e = case e of
+                EEps{} -> True
+                _      -> False
+ 
+ isImin expr' = case expr' of       -- > tells whether the argument is equivalent to I-
+     EEqu (l,r) -> isImin (EIsc (EImp (l,r), EImp (r,l)))       -- TODO: maybe derive something better?
+     EImp (l,r) -> isImin (EUni (ECpl l, r))                  -- TODO: maybe derive something better?
+     EIsc (l,r) -> isImin l && isImin r
+     EUni (l,r) -> isImin l && isImin r
+     EDif (l,r) -> isImin l && isFalse r
+     ECpl e     -> isIdent e
+     EDcD dcl   -> isImin dcl
+     EDcI{}     -> False
+     EEps{}     -> False
+     EDcV{}     -> False
+     EBrk f     -> isImin f
+     EFlp f     -> isImin f
+     _          -> False  -- TODO: find richer answers for ERrs and ELrs
+ src/lib/DatabaseDesign/Ampersand/Classes/ViewPoint.hs view
@@ -0,0 +1,225 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Classes.ViewPoint (Language(..),ProcessStructure(..)) where
+import DatabaseDesign.Ampersand.Core.ParseTree
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+import Prelude hiding (Ord(..))
+import DatabaseDesign.Ampersand.ADL1.Rule                    (rulefromProp, ruleviolations)
+import DatabaseDesign.Ampersand.Classes.Relational  (Relational(multiplicities))
+import DatabaseDesign.Ampersand.Classes.ConceptStructure     (ConceptStructure(..))
+import DatabaseDesign.Ampersand.Basics
+import DatabaseDesign.Ampersand.Misc.Explain
+import Data.List
+ 
+fatal :: Int -> String -> a
+fatal = fatalMsg "Classes.ViewPoint"
+
+-- Language exists because there are many data structures that behave like an ontology, such as Pattern, P_Context, and Rule.
+-- These data structures are accessed by means of a common set of functions (e.g. rules, declarations, etc.)
+
+class Language a where
+  objectdef :: a -> ObjectDef        -- ^ The objectdef that characterizes this viewpoint
+  conceptDefs :: a -> [ConceptDef]   -- ^ all concept definitions that are valid within this viewpoint
+  declarations :: a -> [Declaration] -- ^ all relations that exist in the scope of this viewpoint.
+                                     --   These are user defined declarations and all generated declarations,
+                                     --   i.e. one declaration for each GEN and one for each signal rule.
+                                     --   Don't confuse declarations with declsUsedIn, which gives the declarations that are
+                                     --   used in a.)
+  udefrules :: a -> [Rule]           -- ^ all user defined rules that are maintained within this viewpoint,
+                                     --   which are not multiplicity- and not identity rules.
+  invariants :: a -> [Rule]          -- ^ all rules that are not maintained by users will be maintained by the computer.
+                                     --   That includes multiplicity rules and identity rules, but excludes rules that are assigned to a role.
+                                     -- ^ all relations used in rules must have a valid declaration in the same viewpoint.
+  invariants x  = [r |r<-udefrules x, not (isSignal r)] ++ multrules x ++ identityRules x
+  multrules :: a -> [Rule]           -- ^ all multiplicityrules that are maintained within this viewpoint.
+  multrules x   = [rulefromProp p d |d<-declarations x, p<-multiplicities d]
+  identityRules :: a -> [Rule]          -- all identity rules that are maintained within this viewpoint.
+  identityRules x    = concatMap rulesFromIdentity (identities x)
+  identities :: a -> [IdentityDef]      -- ^ all keys that are defined in a
+  viewDefs :: a -> [ViewDef]         -- ^ all views that are defined in a
+  gens :: a -> [A_Gen]               -- ^ all generalizations that are valid within this viewpoint
+  patterns :: a -> [Pattern]         -- ^ all patterns that are used in this viewpoint
+  
+
+
+class ProcessStructure a where
+  processes :: a -> [Process]       -- ^ all roles that are used in this ProcessStructure
+  roles :: a -> [String]        -- ^ all roles that are used in this ProcessStructure
+  interfaces :: a -> [Interface]     -- ^ all interfaces that are used in this ProcessStructure
+  objDefs :: a -> [ObjectDef]
+  processRules :: a -> [Rule]          -- ^ all process rules that are visible within this viewpoint
+                                       -- ^ all relations used in rules must have a valid declaration in the same viewpoint.
+  maintains :: a -> [(String,Rule)] -- ^ the string represents a Role
+  mayEdit :: a -> [(String,Declaration)] -- ^ the string represents a Role
+  workFromProcessRules :: [A_Gen] -> [Population] -> a -> [(Rule,Paire)]  --the violations of rules and multrules of this viewpoint
+  workFromProcessRules gens' udp x = [(r,viol) |r<-processRules x, viol<-ruleviolations gens' udp r]
+   
+rulesFromIdentity :: IdentityDef -> [Rule]
+rulesFromIdentity identity
+ = [ if null (identityAts identity) then fatal 81 ("Moving into foldr1 with empty list (identityAts identity).") else
+     mkKeyRule
+      ( foldr1 (./\.) [  expr .:. flp expr | IdentityExp att <- identityAts identity, let expr=objctx att ]
+        .|-. EDcI (idCpt identity)) ]
+ {-    diamond e1 e2 = (flp e1 .\. e2) ./\. (e1 ./. flp e2)  -}
+ where ruleName = "identity_" ++ name identity
+       meaningEN = "Identity rule" ++ ", following from identity "++name identity
+       meaningNL = "Identiteitsregel" ++ ", volgend uit identiteit "++name identity
+       mkKeyRule expression =
+         Ru { rrnm   = ruleName
+            , rrexp  = expression
+            , rrfps  = origin identity     -- position in source file
+            , rrmean = AMeaning 
+                         [ A_Markup English ReST (string2Blocks ReST meaningEN)
+                         , A_Markup Dutch ReST (string2Blocks ReST meaningNL)
+                         ]
+            , rrmsg  = []
+            , rrviol = Nothing
+            , rrtyp  = sign expression
+            , rrdcl  = Nothing        -- This rule was not generated from a property of some declaration.
+            , r_env  = ""             -- For traceability: The name of the pattern. Unknown at this position but it may be changed by the environment.
+            , r_usr  = Identity            -- This rule was not specified as a rule in the Ampersand script, but has been generated by a computer
+            , r_sgl  = False          -- This is not a signal rule
+            , srrel  = Sgn  { decnm   = ruleName
+                            , decsgn  = sign expression
+                            , decprps = []
+                            , decprps_calc = Nothing -- []
+                            , decprL  = ""
+                            , decprM  = ""
+                            , decprR  = ""
+                            , decMean = AMeaning 
+                                          [ A_Markup English ReST (string2Blocks ReST meaningEN)
+                                          , A_Markup Dutch ReST (string2Blocks ReST meaningNL)
+                                          ]
+                            , decConceptDef = Nothing
+                            , decfpos = origin identity
+                            , decissX = False
+                            , decusrX = False
+                            , decISA  = False
+                            , decpat  = ""
+                            , decplug = False
+                            }
+            }
+
+instance ProcessStructure a => ProcessStructure [a] where
+  processes     = concatMap processes
+  roles         = concatMap roles
+  interfaces    = concatMap interfaces
+  objDefs       = concatMap objDefs
+  processRules  = concatMap processRules
+  maintains     = concatMap maintains
+  mayEdit       = concatMap mayEdit
+
+instance Language A_Context where
+  objectdef    context = Obj { objnm   = name context
+                             , objpos  = Origin "Object generated by objectdef (Language A_Context)"
+                             , objctx  = EDcI ONE
+                             , objmsub = Just . Box ONE $ map (objectdef) (ctxpats context)
+                             , objstrs = []
+                             }
+  conceptDefs          = ctxcds
+  declarations context = uniteRels (concatMap declarations (patterns context)
+                                 ++ concatMap declarations (processes context)
+                                 ++ ctxds context)
+                         where
+                         -- declarations with the same name, but different properties (decprps,pragma,decpopu,etc.) may exist and need to be united
+                         -- decpopu, decprps and decprps_calc are united, all others are taken from the head.
+                         uniteRels :: [Declaration] -> [Declaration]
+                         uniteRels [] = []
+                         uniteRels ds = [ d | cl<-eqClass (==) ds
+                                            , let d=(head cl){ decprps      = (foldr1 uni.map decprps) cl
+                                                             , decprps_calc = Nothing -- Calculation is only done in ADL2Fspc. -- was:(foldr1 uni.map decprps_calc) cl
+                                                             }]
+  udefrules    context = concatMap udefrules  (ctxpats context) ++ concatMap udefrules  (ctxprocs context) ++ ctxrs context
+  identities   context = concatMap identities (ctxpats context) ++ concatMap identities (ctxprocs context) ++ ctxks context
+  viewDefs     context = concatMap viewDefs   (ctxpats context) ++ concatMap viewDefs   (ctxprocs context) ++ ctxvs context
+  gens         context = concatMap gens       (ctxpats context) ++ concatMap gens       (ctxprocs context) ++ ctxgs context
+  patterns             = ctxpats
+
+instance ProcessStructure A_Context where
+  processes            = ctxprocs
+  roles        context = nub [r | proc<-ctxprocs context, r <- roles proc]
+  interfaces           = ctxifcs
+  objDefs      context = [ifcObj s | s<-ctxifcs context]
+  processRules context = [r |r<-udefrules context, (not.null) [role | (role, rul) <-maintains context, name r == name rul ] ]
+  maintains    context = maintains (ctxprocs context)
+  mayEdit      context = mayEdit (ctxprocs context)
+
+
+instance Language Process where
+  objectdef    prc = Obj { objnm   = name prc
+                         , objpos  = origin prc
+                         , objctx  = EDcI ONE
+                         , objmsub = Nothing
+                         , objstrs = []
+                         }
+  conceptDefs proc  = nub [cd | c<-concs proc,cd<-cptdf c,posIn (prcPos proc) cd (prcEnd proc)]
+  declarations proc = prcDcls proc
+  udefrules         = prcRules -- all user defined rules in this process
+--  invariants   proc = [r | r<-prcRules proc, not (isSignal r) ]
+  identities        = prcIds
+  viewDefs          = prcVds
+  gens              = prcGens
+  patterns      _   = []
+
+instance ProcessStructure Process where
+  processes    proc = [proc]
+  roles        proc = nub ( [r | (r,_) <- prcRRuls proc]++
+                            [r | (r,_) <- prcRRels proc] )
+  interfaces    _   = []
+  objDefs       _   = []
+  processRules proc = [r |r<-prcRules proc, isSignal r]
+  maintains         = prcRRuls  -- says which roles maintain which rules.
+  mayEdit           = prcRRels  -- says which roles may change the population of which relation.
+
+instance Language Pattern where
+  objectdef    pat = Obj { objnm   = name pat
+                         , objpos  = origin pat
+                         , objctx  = EDcI ONE
+                         , objmsub = Nothing
+                         , objstrs = []
+                         }
+  conceptDefs  pat = nub [cd | c<-concs pat,cd<-cptdf c,posIn (ptpos pat) cd (ptend pat)]
+  declarations pat = ptdcs pat
+  udefrules        = ptrls   -- all user defined rules in this pattern
+--  invariants   pat = [r |r<-ptrls pat, not (isSignal r)]
+  identities       = ptids 
+  viewDefs         = ptvds 
+  gens             = ptgns 
+  patterns     pat = [pat]
+
+instance ProcessStructure Pattern where
+  processes     _  = []
+  roles         _  = []
+  interfaces    _  = []
+  objDefs       _  = []
+  processRules pat = [r |r<-ptrls pat, isSignal r]
+  maintains        = ptrruls  -- says which roles maintain which rules.
+  mayEdit          = ptrrels  -- says which roles may change the population of which relation.
+
+instance Language Rule where
+  objectdef rule = Obj { objnm   = name rule
+                       , objpos  = origin rule
+                       , objctx  = EDcI ONE
+                       , objmsub = Nothing
+                       , objstrs = []
+                       }
+  conceptDefs  _ = []
+  declarations r = [srrel r | isSignal r] -- a process rule "declares" a new relation to store violations in. That relation is "stored" in that rule. Therefore it counts as a declaration.
+  udefrules    r = [r | r_usr r == UserDefined ]
+--  invariants   r = [r | not (isSignal r)]
+  identities   _ = []
+  viewDefs     _ = []
+  gens         _ = []
+  patterns r     = [A_Pat{ ptnm  = "Pattern for rule "++name r
+                         , ptpos = Origin "Nameless pattern generated by patterns (Language (Rule(Relation Concept))) "
+                         , ptend = Origin "Nameless pattern generated by patterns (Language (Rule(Relation Concept))) "
+                         , ptrls = [r]
+                         , ptgns = []  -- A rule defines no Gens.
+                         , ptdcs = declsUsedIn r
+                         , ptups = []
+                         , ptrruls = []
+                         , ptrrels = []
+                         , ptids = []
+                         , ptvds = []
+                         , ptxps = []
+                         }
+                   ]
+ src/lib/DatabaseDesign/Ampersand/Components.hs view
@@ -0,0 +1,141 @@+{-# OPTIONS_GHC -Wall #-}
+-- | This module contains the building blocks that are available in the Ampersand Library. These building blocks will be described further at [ampersand.sourceforge.net |the wiki pages of our project].
+-- 
+module DatabaseDesign.Ampersand.Components 
+  ( -- * Type checking and calculus
+     makeFspec
+    -- * Generators of output
+   , generateAmpersandOutput
+--   , doGenADL
+--   , doGenProofs
+--   , doGenHaskell
+--   , doGenXML
+--   , doGenUML
+--   , doGenDocument
+--   , doGenFPAExcel
+   , Guarded(..)
+    -- * etc...
+  )
+where
+import Prelude hiding (putStr,readFile,writeFile)
+import DatabaseDesign.Ampersand.Misc
+import DatabaseDesign.Ampersand.ADL1.P2A_Converters
+import Text.Pandoc 
+import Text.Pandoc.Builder
+import DatabaseDesign.Ampersand.Basics 
+import DatabaseDesign.Ampersand.Fspec
+import DatabaseDesign.Ampersand.Fspec.GenerateUML
+import DatabaseDesign.Ampersand.Fspec.ShowXMLtiny (showXML)
+import DatabaseDesign.Ampersand.Output
+import Control.Monad
+import System.FilePath
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Components"
+
+--  | The Fspc is the datastructure that contains everything to generate the output. This monadic function
+--    takes the Fspc as its input, and spits out everything the user requested.
+generateAmpersandOutput :: Options -> Fspc -> IO ()
+generateAmpersandOutput flags fSpec = 
+ do { verboseLn flags "Generating..."
+    ; when (genXML flags)      $ doGenXML      fSpec flags
+    ; when (genUML flags)      $ doGenUML      fSpec flags 
+    ; when (haskell flags)     $ doGenHaskell  fSpec flags 
+    ; when (export2adl flags)  $ doGenADL      fSpec flags
+    ; when (genFspec flags)    $ doGenDocument fSpec flags 
+    ; when (genFPAExcel flags) $ doGenFPAExcel fSpec flags
+    ; when (proofs flags)      $ doGenProofs   fSpec flags
+    ; when (genMeat flags && not (includeRap flags))  -- When rap is included, the file is created there.
+        $ doGenMeatGrinder fSpec flags
+    --; Prelude.putStrLn $ "Declared rules:\n" ++ show (map showADL $ vrules fSpec)
+    --; Prelude.putStrLn $ "Generated rules:\n" ++ show (map showADL $ grules fSpec)
+    --; Prelude.putStrLn $ "Violations:\n" ++ show (violations fSpec)
+    ; verboseLn flags "Done."
+    }
+
+-- An expression e is type ambiguous means that   (showADL e) cannot be parsed (in the context of fSpec) without a type ambiguity error.
+-- Q: Should we disambiguate the exprs in the fspec i.e. mapexprs disambiguate fSpec fSpec?
+--    Or do we assume a correct implementation with unambiguous expressions only?
+-- A: The fSpec may contain disambiguated expressions only. If one expression somewhere in fSpec is type-ambiguous, fSpec is wrong.
+--    So the answer is: we assume a correct implementation with unambiguous expressions only.
+doGenADL :: Fspc -> Options -> IO()
+doGenADL    fSpec flags =
+ do { writeFile outputFile (showADL fSpec) 
+    ; verboseLn flags $ ".adl-file written to " ++ outputFile ++ "."
+    }
+ where outputFile = combine (dirOutput flags) (outputfile flags)
+
+doGenProofs :: Fspc -> Options -> IO()
+doGenProofs fSpec flags =
+ do { verboseLn flags $ "Generating Proof for " ++ name fSpec ++ " into " ++ outputFile ++ "."
+    ; writeFile outputFile $ writeHtmlString def thePandoc
+    ; verboseLn flags "Proof written."
+    }
+ where outputFile = combine (dirOutput flags) $ replaceExtension ("proofs_of_"++baseName flags) ".html" 
+       thePandoc = setTitle title (doc theDoc)
+       title  = text $ "Proofs for "++name fSpec
+       theDoc = para $ fromList (deriveProofs flags fSpec)
+       --theDoc = plain (text "Aap")  -- use for testing...
+
+doGenHaskell :: Fspc -> Options -> IO()
+doGenHaskell fSpec flags =
+ do { verboseLn flags $ "Generating Haskell source code for "++name fSpec
+--    ; verboseLn flags $ fSpec2Haskell fSpec flags
+    ; writeFile outputFile (fSpec2Haskell fSpec flags) 
+    ; verboseLn flags $ "Haskell written into " ++ outputFile ++ "."
+    }
+ where outputFile = combine (dirOutput flags) $ replaceExtension (baseName flags) ".hs"
+   
+doGenMeatGrinder :: Fspc -> Options -> IO()
+doGenMeatGrinder fSpec flags =
+ do verboseLn flags $ "Generating meta-population for "++name fSpec
+    let (nm,content) = meatGrinder flags fSpec
+        outputFile = combine (dirOutput flags) $ replaceExtension nm ".adl"
+    writeFile outputFile content
+    verboseLn flags $ "Meta population written into " ++ outputFile ++ "."
+   
+doGenXML :: Fspc -> Options -> IO()
+doGenXML fSpec flags =
+ do { verboseLn flags "Generating XML..."
+    ; writeFile outputFile $ showXML fSpec (genTime flags)   
+    ; verboseLn flags $ "XML written into " ++ outputFile ++ "."
+    }
+   where outputFile = combine (dirOutput flags) $ replaceExtension (baseName flags) ".xml"
+               
+doGenUML :: Fspc -> Options -> IO()
+doGenUML fSpec flags =
+ do { verboseLn flags "Generating UML..."
+    ; writeFile outputFile $ generateUML fSpec flags
+    ; Prelude.putStrLn $ "Generated file: " ++ outputFile ++ "."
+    }
+   where outputFile = combine (dirOutput flags) $ replaceExtension (baseName flags) ".xmi"
+
+-- This function will generate all Pictures for a given Fspc. 
+-- the returned Fspc contains the details about the Pictures, so they
+-- can be referenced while rendering the Fspc.
+-- This function generates a pandoc document, possibly with pictures from an fSpec.
+doGenDocument :: Fspc -> Options -> IO()
+doGenDocument fSpec flags =
+ do { verboseLn flags ("Processing "++name fSpec)
+    ; makeOutput
+    ; verboseLn flags $ "Document has been written to " ++ outputFile ++ "."
+    ; when (genGraphics flags && not(null thePictures) && fspecFormat flags/=FPandoc) $ 
+        mapM_ (writePicture flags) thePictures
+     -- postProcessing of the generated output file depends on the format:
+    ; postProcessor
+    }
+  where (thePandoc,thePictures) = 
+          case (theme flags, fspecFormat flags) of
+ -- TODO Ticket #104: Could not find texOnly_proofdoc in any module? Where has in gone?
+ --                (ProofTheme, FLatex ) -> (texOnly_proofdoc fSpec,[])     --generate a proof document
+                 (ProofTheme, _      ) -> fatal 116 "Ampersand only supports proof documents output in LaTeX format. try `-fLatex` "
+                 (_         , _      ) -> fSpec2Pandoc fSpec flags
+        (outputFile,makeOutput,postProcessor) = writepandoc flags fSpec thePandoc
+
+-- | This function will generate an Excel workbook file, containing an extract from the Fspc
+doGenFPAExcel :: Fspc -> Options -> IO()
+doGenFPAExcel fSpec flags =
+ do { verboseLn flags "Generating Excel..."
+    ; writeFile outputFile (showSpreadsheet (fspec2Workbook fSpec flags))
+    }
+   where outputFile = combine (dirOutput flags) $ replaceExtension ("FPA_"++baseName flags) ".xml"  -- Do not use .xls here, because that generated document contains xml.
+ src/lib/DatabaseDesign/Ampersand/Core/AbstractSyntaxTree.hs view
@@ -0,0 +1,602 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-}+module DatabaseDesign.Ampersand.Core.AbstractSyntaxTree (+   A_Context(..)+ , Meta(..)+ , Theme(..)+ , Process(..)+ , Pattern(..)+ , PairView(..)+ , PairViewSegment(..)+ , Rule(..)+ , RuleType(..)+ , RuleOrigin(..)+ , Declaration(..), decusr, deciss+ , IdentityDef(..)+ , IdentitySegment(..)+ , ViewDef(..)+ , ViewSegment(..)+ , A_Gen(..)+ , Interface(..)+ , SubInterface(..)+ , ObjectDef(..)+ , objAts+ , objatsLegacy -- for use in legacy code only+ , Purpose(..)+ , ExplObj(..)+ , Expression(..)+ , A_Concept(..)+ , A_Markup(..)+ , AMeaning(..)+ , RoleRelation(..)+ , Sign(..)+ , Population(..)+ , GenR+ , Signaling(..)+ , Association(..)+  -- (Poset.<=) is not exported because it requires hiding/qualifying the Prelude.<= or Poset.<= too much+  -- import directly from DatabaseDesign.Ampersand.Core.Poset when needed+ , (<==>),join,meet,greatest,least,maxima,minima,sortWith + , smallerConcepts, largerConcepts, rootConcepts+ , showSign+ , aMarkup2String+ , insParentheses+ , module DatabaseDesign.Ampersand.Core.ParseTree  -- export all used contstructors of the parsetree, because they have actually become part of the Abstract Syntax Tree.+ , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.:.), (.!.), (.*.)+)where+import qualified Prelude+import Prelude hiding (Ord(..), Ordering(..))+import DatabaseDesign.Ampersand.Basics+import DatabaseDesign.Ampersand.Core.ParseTree   (MetaObj(..),Meta(..),ConceptDef,Origin(..),Traced(..),PairView(..),PairViewSegment(..),Prop,Lang,Pairs, PandocFormat, P_Markup(..), PMeaning(..), SrcOrTgt(..), isSrc, RelConceptDef(..))+import DatabaseDesign.Ampersand.Core.Poset (Poset(..), Sortable(..),Ordering(..),greatest,least,maxima,minima,sortWith)+import DatabaseDesign.Ampersand.Misc+import Text.Pandoc hiding (Meta)+import Data.List (intercalate,nub)+fatal :: Int -> String -> a+fatal = fatalMsg "Core.AbstractSyntaxTree"++data A_Context+   = ACtx{ ctxnm :: String           -- ^ The name of this context+         , ctxpos :: [Origin]        -- ^ The origin of the context. A context can be a merge of a file including other files c.q. a list of Origin.+         , ctxlang :: Lang           -- ^ The default language used in this context.+         , ctxmarkup :: PandocFormat -- ^ The default markup format for free text in this context (currently: LaTeX, ...)+         , ctxthms :: [String]       -- ^ Names of patterns/processes to be printed in the functional specification. (For partial documents.)+         , ctxpats :: [Pattern]      -- ^ The patterns defined in this context+         , ctxprocs :: [Process]     -- ^ The processes defined in this context+         , ctxrs :: [Rule]           -- ^ All user defined rules in this context, but outside patterns and outside processes+         , ctxds :: [Declaration]    -- ^ The declarations defined in this context, outside the scope of patterns+         , ctxpopus :: [Population]  -- ^ The user defined populations of relations defined in this context, including those from patterns and processes+         , ctxcds :: [ConceptDef]    -- ^ The concept definitions defined in this context, including those from patterns and processes+         , ctxks :: [IdentityDef]    -- ^ The identity definitions defined in this context, outside the scope of patterns+         , ctxvs :: [ViewDef]        -- ^ The view definitions defined in this context, outside the scope of patterns+         , ctxgs :: [A_Gen]          -- ^ The specialization statements defined in this context, outside the scope of patterns+         , ctxgenconcs :: [[A_Concept]] -- ^ A partitioning of all concepts: the union of all these concepts contains all atoms, and the concept-lists are mutually distinct in terms of atoms in one of the mentioned concepts+         , ctxifcs :: [Interface]    -- ^ The interfaces defined in this context, outside the scope of patterns+         , ctxps :: [Purpose]        -- ^ The purposes of objects defined in this context, outside the scope of patterns+         , ctxsql :: [ObjectDef]     -- ^ user defined sqlplugs, taken from the Ampersand script+         , ctxphp :: [ObjectDef]     -- ^ user defined phpplugs, taken from the Ampersand script+         , ctxmetas :: [Meta]        -- ^ used for Pandoc authors (and possibly other things)+         }               --deriving (Show) -- voor debugging+instance Show A_Context where+  showsPrec _ c = showString (ctxnm c)+instance Eq A_Context where+  c1 == c2  =  name c1 == name c2+instance Identified A_Context where+  name  = ctxnm +++data Theme = PatternTheme Pattern | ProcessTheme Process++instance Identified Theme where+  name (PatternTheme pat) = name pat+  name (ProcessTheme prc) = name prc+  +instance Traced Theme where+  origin (PatternTheme pat) = origin pat+  origin (ProcessTheme prc) = origin prc+  +data Process = Proc { prcNm :: String+                    , prcPos :: Origin+                    , prcEnd :: Origin      -- ^ the end position in the file, elements with a position between pos and end are elements of this process.+                    , prcRules :: [Rule]+                    , prcGens :: [A_Gen]+                    , prcDcls :: [Declaration]+                    , prcUps :: [Population]  -- ^ The user defined populations in this process+                    , prcRRuls :: [(String,Rule)]    -- ^ The assignment of roles to rules.+                    , prcRRels :: [(String,Declaration)] -- ^ The assignment of roles to Relations.+                    , prcIds :: [IdentityDef]            -- ^ The identity definitions defined in this process+                    , prcVds :: [ViewDef]            -- ^ The view definitions defined in this process+                    , prcXps :: [Purpose]           -- ^ The motivations of elements defined in this process+                    }+instance Identified Process where+  name = prcNm++instance Traced Process where+  origin = prcPos++data RoleRelation+   = RR { rrRoles :: [String]     -- ^ name of a role+        , rrRels :: [Declaration]   -- ^ name of a Relation+        , rrPos :: Origin       -- ^ position in the Ampersand script+        } --deriving (Eq, Show)     -- just for debugging+instance Traced RoleRelation where+   origin = rrPos+    +++data Pattern+   = A_Pat { ptnm :: String         -- ^ Name of this pattern+           , ptpos :: Origin        -- ^ the position in the file in which this pattern was declared.+           , ptend :: Origin        -- ^ the end position in the file, elements with a position between pos and end are elements of this pattern.+           , ptrls :: [Rule]        -- ^ The user defined rules in this pattern+           , ptgns :: [A_Gen]       -- ^ The generalizations defined in this pattern+           , ptdcs :: [Declaration] -- ^ The declarations declared in this pattern+           , ptups :: [Population]  -- ^ The user defined populations in this pattern+           , ptrruls :: [(String,Rule)]         -- ^ The assignment of roles to rules.+           , ptrrels :: [(String,Declaration)]  -- ^ The assignment of roles to Relations.+           , ptids :: [IdentityDef] -- ^ The identity definitions defined in this pattern+           , ptvds :: [ViewDef]     -- ^ The view definitions defined in this pattern+           , ptxps :: [Purpose]     -- ^ The purposes of elements defined in this pattern+           }   --deriving (Show)    -- for debugging purposes+instance Identified Pattern where+ name = ptnm+instance Traced Pattern where+ origin = ptpos++data A_Markup =+    A_Markup { amLang :: Lang+             , amFormat :: PandocFormat+             , amPandoc :: [Block]+             } deriving Show++data RuleOrigin = UserDefined     -- This rule was specified explicitly as a rule in the Ampersand script+                | Multiplicity    -- This rule follows implicitly from the Ampersand script (Because of a property) and generated by a computer+                | Identity             -- This rule follows implicitly from the Ampersand script (Because of a identity) and generated by a computer+                deriving (Show, Eq)+data Rule =+     Ru { rrnm :: String                  -- ^ Name of this rule+        , rrexp :: Expression              -- ^ The rule expression+        , rrfps :: Origin                  -- ^ Position in the Ampersand file+        , rrmean :: AMeaning                -- ^ Ampersand generated meaning (for all known languages)+        , rrmsg :: [A_Markup]              -- ^ User-specified violation messages, possibly more than one, for multiple languages.+        , rrviol :: Maybe (PairView Expression) -- ^ Custom presentation for violations, currently only in a single language+        , rrtyp :: Sign                    -- ^ Allocated type+        , rrdcl :: Maybe (Prop,Declaration)  -- ^ The property, if this rule originates from a property on a Declaration+        , r_env :: String                  -- ^ Name of pattern in which it was defined.+        , r_usr :: RuleOrigin              -- ^ Where does this rule come from?+        , r_sgl :: Bool                    -- ^ True if this is a signal; False if it is an invariant+        , srrel :: Declaration             -- ^ the signal relation+        }+instance Eq Rule where+  r==r' = rrnm r==rrnm r'+instance Show Rule where+  showsPrec _ x+   = showString $ "RULE "++ (if null (name x) then "" else name x++": ")++ show (rrexp x)+instance Traced Rule where+  origin = rrfps+instance Identified Rule where+  name   = rrnm+instance Association Rule where+  sign   = rrtyp+instance Signaling Rule where+  isSignal = r_sgl++data RuleType = Implication | Equivalence | Truth  deriving (Eq,Show)++data Declaration = +  Sgn { decnm :: String     -- ^ the name of the declaration+      , decsgn :: Sign       -- ^ the source and target concepts of the declaration+       --multiplicities returns decprps_calc, when it has been calculated. So if you only need the user defined properties do not use multiplicities but decprps+      , decprps :: [Prop]     -- ^ the user defined multiplicity properties (Uni, Tot, Sur, Inj) and algebraic properties (Sym, Asy, Trn, Rfx)+      , decprps_calc :: Maybe [Prop] -- ^ the calculated and user defined multiplicity properties (Uni, Tot, Sur, Inj) and algebraic properties (Sym, Asy, Trn, Rfx, Irf). Note that calculated properties are made by adl2fspec, so in the A-structure decprps and decprps_calc yield exactly the same answer.+      , decprL :: String     -- ^ three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas."+      , decprM :: String     -- ^    then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas.+      , decprR :: String+      , decMean :: AMeaning   -- ^ the meaning of a declaration, for each language supported by Ampersand.+      , decConceptDef :: Maybe RelConceptDef -- ^ alternative definition for the source or target concept in the context of this relation+ --     , decpopu :: Pairs      -- ^ the list of tuples, of which the relation consists.+      , decfpos :: Origin     -- ^ the position in the Ampersand source file where this declaration is declared. Not all decalartions come from the ampersand souce file. +      , decissX :: Bool       -- ^ if true, this is a signal relation; otherwise it is an ordinary relation.+      , decusrX :: Bool       -- ^ if true, this relation is declared by an author in the Ampersand script; otherwise it was generated by Ampersand.+      , decISA ::  Bool      -- ^ if true, this relation is the result of an ISA declaration.+      , 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+      }+decusr :: Declaration -> Bool+decusr Sgn{decusrX=b}=b+decusr _ = False+deciss :: Declaration -> Bool+deciss Sgn{decissX=b}=b+deciss _ = False++instance Eq Declaration where+  d@Sgn{}     == d'@Sgn{}     = decnm d==decnm d' && decsgn d==decsgn d'+  d@Isn{}     == d'@Isn{}     = detyp d==detyp d'+  d@Vs{}      == d'@Vs{}      = decsgn d==decsgn d'+  _           == _            = False+instance Show Declaration where  -- For debugging purposes only (and fatal messages)+  showsPrec _ d@Sgn{}+    = showString (unwords (["RELATION",decnm d,show (decsgn d),show (decprps_calc d)+                           ,"PRAGMA",show (decprL d),show (decprM d),show (decprR d)]+                            ++concatMap showMeaning (ameaMrk (decMean d))+                 )        )+           where +              showMeaning m = "MEANING"+                             : ["IN", show (amLang m)]+                            ++ [show (amFormat m)]+                            ++ ["{+",aMarkup2String m,"-}"]                +                            -- then [] else ["MEANING",show (decMean d)] ))+  showsPrec _ d@Isn{}     = showString $ "Isn{detyp="++show(detyp d)++"}"+  showsPrec _ d@Vs{}      = showString $ "V"++showSign(decsgn d)+++aMarkup2String :: A_Markup -> String+aMarkup2String a = blocks2String (amFormat a) False (amPandoc a)++data AMeaning = AMeaning { ameaMrk ::[A_Markup]} deriving Show++instance Identified Declaration where+  name d@Sgn{}   = decnm d+  name Isn{}     = "I"+  name Vs{}      = "V"+instance Association Declaration where+  sign d = case d of+              Sgn {}    -> decsgn d+              Isn {}    -> Sign (detyp d) (detyp d)+              Vs {}     -> decsgn d+instance Traced Declaration where+  origin d = case d of+              Sgn{}     -> decfpos d+              _         -> OriginUnknown++data IdentityDef = Id { idPos :: Origin        -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number).+                      , idLbl :: String        -- ^ the name (or label) of this Identity. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface. It is not an empty string.+                      , idCpt :: A_Concept     -- ^ this expression describes the instances of this object, related to their context+                      , identityAts :: [IdentitySegment]  -- ^ the constituent attributes (i.e. name/expression pairs) of this identity.+                      } deriving (Eq,Show)+instance Identified IdentityDef where+  name = idLbl+instance Traced IdentityDef where+  origin = idPos++data IdentitySegment = IdentityExp ObjectDef deriving (Eq, Show)  -- TODO: refactor to a list of terms++data ViewDef = Vd { vdpos :: Origin         -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number).+                  , vdlbl :: String         -- ^ the name (or label) of this View. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface. It is not an empty string.+                  , vdcpt :: A_Concept      -- ^ this expression describes the instances of this object, related to their context+                  , vdats :: [ViewSegment]  -- ^ the constituent attributes (i.e. name/expression pairs) of this view.+                  } deriving (Eq,Show)+instance Identified ViewDef where+  name = vdlbl+instance Traced ViewDef where+  origin = vdpos++data ViewSegment = ViewExp ObjectDef | ViewText String | ViewHtml String deriving (Eq, Show)++-- | data structure A_Gen contains the CLASSIFY statements from an Ampersand script+--   CLASSIFY Employee ISA Person   translates to Isa orig (C "Person") (C "Employee")+--   CLASSIFY Workingstudent IS Employee/\Student   translates to IsE orig [C "Employee",C "Student"] (C "Workingstudent")+data A_Gen = Isa { genfp :: Origin          -- ^ the position of the GEN-rule+                 , gengen :: A_Concept      -- ^ generic concept+                 , genspc :: A_Concept      -- ^ specific concept+                 }+           | IsE { genfp :: Origin          -- ^ the position of the GEN-rule+                 , genrhs :: [A_Concept]    -- ^ concepts of which the conjunction is equivalent to the specific concept+                 , genspc :: A_Concept      -- ^ specific concept+                 }+instance Show A_Gen where+  -- This show is used in error messages. It should therefore not display the term's type+  showsPrec _ g@(Isa{}) = showString ("CLASSIFY "++show (genspc g)++" ISA "++show (gengen g))+  showsPrec _ g@(IsE{}) = showString ("CLASSIFY "++show (genspc g)++" IS "++intercalate " /\\ " (map show $ genrhs g))+instance Traced A_Gen where+  origin = genfp++-- | 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 = 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  = nub$[ gengen g | g@Isa{}<-gens, genspc g==cpt ]++[ c | g@IsE{}<-gens, genspc g==cpt, c<-genrhs g ] ++-- | this function returns the most generic concepts in the class of a given concept+rootConcepts :: [A_Gen]  -> [A_Concept] -> [A_Concept]+rootConcepts gens cpts = [ root | root<-nub $ [ c | cpt<-cpts, c<-largerConcepts gens cpt ] `uni` cpts+                                , root `notElem` [ genspc g | g@Isa{}<-gens]++[c | g@IsE{}<-gens, c<-genrhs g ]+                                ]++data Interface = Ifc { ifcParams :: [Expression] -- Only primitive expressions are allowed!+                     , ifcArgs ::   [[String]]+                     , ifcRoles ::  [String]+                     , ifcObj ::    ObjectDef -- NOTE: this top-level ObjectDef is contains the interface itself (ie. name and expression)+                     , ifcPos ::    Origin+                     , ifcPrp ::    String+                     } deriving Show+instance Eq Interface where+  s==s' = name s==name s'+instance Identified Interface where+  name = name . ifcObj+instance Traced Interface where+  origin = ifcPos++objAts :: ObjectDef -> [ObjectDef]+objAts Obj{ objmsub=Nothing } = []+objAts Obj{ objmsub=Just (InterfaceRef _) } = []+objAts Obj{ objmsub=Just (Box _ objs) } = objs++objatsLegacy :: ObjectDef -> [ObjectDef]+objatsLegacy Obj{ objmsub=Nothing } = []+objatsLegacy Obj{ objmsub=Just (Box _ objs) } = objs+objatsLegacy Obj{ objmsub=Just (InterfaceRef _) } = fatal 301 $ "Using functionality that has not been extended to InterfaceRefs"++data ObjectDef = Obj { objnm ::   String         -- ^ view name of the object definition. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface if it is not an empty string.+                     , objpos ::  Origin         -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number)+                     , objctx ::  Expression     -- ^ this expression describes the instances of this object, related to their context. +                     , objmsub :: Maybe SubInterface    -- ^ the attributes, which are object definitions themselves.+                     , objstrs :: [[String]]     -- ^ directives that specify the interface.+                     } deriving (Eq, Show)       -- just for debugging (zie ook instance Show ObjectDef)+instance Identified ObjectDef where+  name   = objnm+instance Traced ObjectDef where+  origin = objpos++data SubInterface = Box A_Concept [ObjectDef] | InterfaceRef String deriving (Eq, Show) ++-- | Explanation is the intended constructor. It explains the purpose of the object it references.+--   The enrichment process of the parser must map the names (from PPurpose) to the actual objects+data Purpose  = Expl { explPos :: Origin     -- ^ The position in the Ampersand script of this purpose definition+                     , explObj :: ExplObj    -- ^ The object that is explained.+                     , explMarkup :: A_Markup   -- ^ This field contains the text of the explanation including language and markup info.+                     , explUserdefd :: Bool       -- ^ Is this purpose defined in the script?+                     , explRefId :: String     -- ^ The reference of the explaination+                     } +instance Eq Purpose where+  x0 == x1  =  explObj x0 == explObj x1 && +               (amLang . explMarkup) x0 == (amLang . explMarkup) x1+instance Traced Purpose where+  origin = explPos++data Population -- The user defined populations+  = PRelPopu { popdcl :: Declaration+             , popps ::  Pairs     -- The user-defined pairs that populate the relation+             }+  | PCptPopu { popcpt :: A_Concept+             , popas ::  [String]  -- The user-defined atoms that populate the concept+             }++data ExplObj = ExplConceptDef ConceptDef+             | ExplDeclaration Declaration+             | ExplRule String+             | ExplIdentityDef String+             | ExplViewDef String+             | ExplPattern String+             | ExplProcess String+             | ExplInterface String+             | ExplContext String+          deriving (Show ,Eq)++data Expression+      = EEqu (Expression,Expression)   -- ^ equivalence             =+      | EImp (Expression,Expression)   -- ^ implication             |-+      | EIsc (Expression,Expression)   -- ^ intersection            /\+      | EUni (Expression,Expression)   -- ^ union                   \/+      | EDif (Expression,Expression)   -- ^ difference              -+      | ELrs (Expression,Expression)   -- ^ left residual           /+      | ERrs (Expression,Expression)   -- ^ right residual          \+      | ECps (Expression,Expression)   -- ^ composition             ; +      | ERad (Expression,Expression)   -- ^ relative addition       ! +      | EPrd (Expression,Expression)   -- ^ cartesian product       * +      | EKl0 Expression                -- ^ Rfx.Trn closure         *  (Kleene star)+      | EKl1 Expression                -- ^ Transitive closure      +  (Kleene plus)+      | EFlp Expression                -- ^ conversion (flip, wok)  ~+      | ECpl Expression                -- ^ Complement+      | EBrk Expression                -- ^ bracketed expression ( ... )+      | EDcD Declaration               -- ^ simple declaration+      | EDcI A_Concept                 -- ^ Identity relation+      | EEps A_Concept Sign            -- ^ Epsilon relation (introduced by the system to ensure we compare concepts by equality only.+      | EDcV Sign                      -- ^ Cartesian product relation+      | EMp1 String A_Concept          -- ^ constant (string between single quotes)+      deriving (Eq,Show)++(.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.:.), (.!.), (.*.) :: Expression -> Expression -> Expression++infixl 1 .==.   -- equivalence+infixl 1 .|-.   -- implication+infixl 2 ./\.   -- intersection+infixl 2 .\/.   -- union+infixl 4 .-.    -- difference+infixl 6 ./.    -- left residual+infixl 6 .\.    -- right residual+infixl 8 .:.    -- composition    -- .;. was unavailable, because Haskell's scanner does not recognize it as an operator.+infixl 8 .!.    -- relative addition+infixl 8 .*.    -- cartesian product++-- SJ 2013118: The fatals are superfluous, but only if the type checker works correctly. Once we have sufficient confidence, they can be removed for performance reasons.+l .==. r = if source l/=source r ||  target l/=target r then fatal 424 ("Cannot equate (with operator \"==\") expression\n   "++show l++"\n   with "++show r++".") else+           EEqu (l,r)+l .|-. r = if source l/=source r ||  target l/=target r then fatal 426 ("Cannot include (with operator \"|-\") expression\n   "++show l++"\n   with "++show r++".") else+           EImp (l,r)+l ./\. r = if source l/=source r ||  target l/=target r then fatal 428 ("Cannot intersect (with operator \"/\\\") expression\n   "++show l++"\n   with "++show r++".") else+           EIsc (l,r)+l .\/. r = if source l/=source r ||  target l/=target r then fatal 430 ("Cannot unite (with operator \"\\/\") expression\n   "++show l++"\n   with "++show r++".") else+           EUni (l,r)+l .-. r  = if source l/=source r ||  target l/=target r then fatal 432 ("Cannot subtract (with operator \"-\") expression\n   "++show l++"\n   with "++show r++".") else+           EDif (l,r)+l ./. r  = if target l/=target r then fatal 434 ("Cannot residuate (with operator \"/\") expression\n   "++show l++"\n   with "++show r++".") else+           ELrs (l,r)+l .\. r  = if source l/=source r then fatal 436 ("Cannot residuate (with operator \"\\\") expression\n   "++show l++"\n   with "++show r++".") else+           ERrs (l,r)+l .:. r  = if source r/=target l then fatal 438 ("Cannot compose (with operator \";\") expression\n   "++show l++"\n   with "++show r++".") else+           ECps (l,r)+l .!. r  = if source r/=target l then fatal 440 ("Cannot add (with operator \"!\") expression\n   "++show l++"\n   with "++show r++".") else+           ERad (l,r)+l .*. r  = -- SJC: should always fit! No fatal here..+           EPrd (l,r)+{- For the operators /, \, ;, ! and * we must not check whether the intermediate types exist.+   Suppose the user says GEN Student ISA Person and GEN Employee ISA Person, then Student `join` Employee has a name (i.e. Person), but Student `meet` Employee+   does not. In that case, -(r!s) (with target r=Student and source s=Employee) is defined, but -r;-s is not.+   So in order to let -(r!s) be equal to -r;-s we must not check for the existence of these types, for the Rotterdam paper already shows that this is fine.+-}++instance Flippable Expression where+  flp expr = case expr of+               EEqu (l,r) -> EEqu (flp l, flp r)+               EImp (l,r) -> EImp (flp l, flp r)+               EIsc (l,r) -> EIsc (flp l, flp r)+               EUni (l,r) -> EUni (flp l, flp r)+               EDif (l,r) -> EDif (flp l, flp r)+               ELrs (l,r) -> ERrs (flp r, flp l)+               ERrs (l,r) -> ELrs (flp r, flp l)+               ECps (l,r) -> ECps (flp r, flp l)+               ERad (l,r) -> ERad (flp r, flp l)+               EPrd (l,r) -> EPrd (flp r, flp l)+               EFlp e     -> e+               ECpl e     -> ECpl (flp e)+               EKl0 e     -> EKl0 (flp e)+               EKl1 e     -> EKl1 (flp e)+               EBrk f     -> EBrk (flp f)+               EDcD{}     -> EFlp expr +               EDcI{}     -> expr+               EEps i sgn -> EEps i (flp sgn)+               EDcV sgn   -> EDcV (flp sgn)+               EMp1{}     -> expr++insParentheses :: Expression -> Expression+insParentheses = insPar 0+      where+       wrap :: Integer -> Integer -> Expression -> Expression+       wrap i j e' = if i<=j then e' else EBrk e'+       insPar :: Integer -> Expression -> Expression+       insPar i (EEqu (l,r)) = wrap i     0 (EEqu (insPar 1 l, insPar 1 r))+       insPar i (EImp (l,r)) = wrap i     0 (EImp (insPar 1 l, insPar 1 r))+       insPar i (EUni (l,r)) = wrap (i+1) 2 (EUni (insPar 2 l, insPar 2 r))+       insPar i (EIsc (l,r)) = wrap (i+1) 2 (EIsc (insPar 2 l, insPar 2 r))+       insPar i (EDif (l,r)) = wrap i     4 (EDif (insPar 5 l, insPar 5 r))+       insPar i (ELrs (l,r)) = wrap i     6 (ELrs (insPar 7 l, insPar 7 r))+       insPar i (ERrs (l,r)) = wrap i     6 (ERrs (insPar 7 l, insPar 7 r))+       insPar i (ECps (l,r)) = wrap (i+1) 8 (ECps (insPar 8 l, insPar 8 r))+       insPar i (ERad (l,r)) = wrap (i+1) 8 (ERad (insPar 8 l, insPar 8 r))+       insPar i (EPrd (l,r)) = wrap (i+1) 8 (EPrd (insPar 8 l, insPar 8 r))+       insPar _ (EKl0 e)     = EKl0 (insPar 10 e)+       insPar _ (EKl1 e)     = EKl1 (insPar 10 e)+       insPar _ (EFlp e)     = EFlp (insPar 10 e)+       insPar _ (ECpl e)     = ECpl (insPar 10 e)+       insPar i (EBrk f)     = insPar i f+       insPar _ e@EDcD{}     = e+       insPar _ e@EDcI{}     = e+       insPar _ e@EEps{}     = e+       insPar _ e@EDcV{}     = e+       insPar _ e@EMp1{}     = e++instance Association Expression where+ sign (EEqu (l,r)) = Sign (source l) (target r)+ sign (EImp (l,r)) = Sign (source l) (target r)+ sign (EIsc (l,r)) = Sign (source l) (target r)+ sign (EUni (l,r)) = Sign (source l) (target r)+ sign (EDif (l,r)) = Sign (source l) (target r)+ sign (ELrs (l,r)) = Sign (source l) (source r)+ sign (ERrs (l,r)) = Sign (target l) (target r)+ sign (ECps (l,r)) = Sign (source l) (target r)+ sign (ERad (l,r)) = Sign (source l) (target r)+ sign (EPrd (l,r)) = Sign (source l) (target r)+ sign (EKl0 e)     = sign e+ sign (EKl1 e)     = sign e+ sign (EFlp e)     = flp (sign e)+ sign (ECpl e)     = sign e+ sign (EBrk e)     = sign e+ sign (EDcD d)     = sign d+ sign (EDcI c)     = Sign c c+ sign (EEps _ sgn) = sgn+ sign (EDcV sgn)   = sgn+ sign (EMp1 _ c)   = Sign c c++showSign :: Association a => a -> String+showSign x = let Sign s t = sign x in "["++name s++"*"++name t++"]"++-- The following definition of concept is used in the type checker only.+-- It is called Concept, meaning "type checking concept"++data A_Concept+   = PlainConcept   +         { cptnm :: String         -- ^The name of this Concept+         , cpttp :: String         -- ^The (SQL) type of this Concept+         , cptdf :: [ConceptDef]   -- ^Concept definitions of this concept.+         }  -- ^PlainConcept nm tp cs represents the set of instances cs by name nm.+   | ONE  -- ^The universal Singleton: 'I'['Anything'] = 'V'['Anything'*'Anything']++instance Eq A_Concept where+   PlainConcept{cptnm=a} == PlainConcept{cptnm=b} = a==b+   ONE == ONE = True+   _ == _ = False++instance Identified A_Concept where+  name PlainConcept{cptnm = nm} = nm+  name ONE = "ONE"++instance Show A_Concept where+  showsPrec _ c = showString (name c)+   +  +data Sign = Sign A_Concept A_Concept deriving Eq+  ++instance Show Sign where+  showsPrec _ (Sign s t) = +     showString (   "[" ++ show s ++ "*" ++ show t ++ "]" )++instance Association Sign where+  source (Sign s _) = s+  target (Sign _ t) = t+  sign sgn = sgn++instance Flippable Sign where+ flp (Sign s t) = Sign t s++class Association rel where+  source, target :: rel -> A_Concept      -- e.g. Declaration -> Concept+  source x        = source (sign x)+  target x        = target (sign x)+  sign :: rel -> Sign+  isEndo :: rel  -> Bool+  isEndo s        = source s == target s++class Signaling a where+  isSignal :: a -> Bool  -- > tells whether the argument refers to a signal+    ++{- +  --  a <= b means that concept a is more specific than b and b is more generic than a. For instance 'Elephant' <= 'Animal'+  --  The generalization relation <= between concepts is a partial order.+  --  Partiality reflects the fact that not every pair of concepts of a specification need be related.+  --  Although meets, joins and sorting of all concepts may be meaningless, within classes of comparable concepts it is meaningfull.+  --  See Core.Poset to see how these functions are defined for the meaningfull cases only.+  --  Core.Poset is based and partly copied from http://hackage.haskell.org/package/altfloat-0.3.1 intended to sort floats and more+  --  A partial order is by definition reflexive, antisymmetric, and transitive+  --  For every concept a and b in Ampersand, the following rule holds: a<b || b<a || a==b || a <==> b || a<\=> b+  --  Every concept drags around the same partial order represented by +  --   + a compare function (A_Concept->A_Concept->Ordering) +  --   + and a list of comparable classes [[A_Concept]]+-}+type GenR = ( A_Concept -> A_Concept -> Ordering      --  gE: the ordering relation, which yields EQ, LT, GT, CP, or NC+            , [[A_Concept]]                           --  join classes. Each class corresponds to a (scalar, binary or wide) entity later on in the database generator.+            , [(A_Concept,A_Concept)]                 --  the smallest set of pairs that produces the ordering relation gE+            , A_Concept -> A_Concept -> [A_Concept]   --  c `elem` (a `meets` b) means that c<=q and c<=b +            , A_Concept -> A_Concept -> [A_Concept]   --  c `elem` (a `joins` b) means that c>=q and c>=b +            )+++{- not used, but may be handy for debugging+showOrder :: A_Concept -> String+showOrder x = "\nComparability classes:"++ind++intercalate ind (map show classes)+ where (_,classes,_,_,_) = cptgE x; ind = "\n   "+-}
+ src/lib/DatabaseDesign/Ampersand/Core/ParseTree.hs view
@@ -0,0 +1,608 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Core.ParseTree (
+     P_Context(..)
+   , Meta(..)
+   , MetaObj(..)
+   , P_Process(..)
+   , P_RoleRelation(..)
+   , RoleRule(..)
+   , P_Pattern(..)
+   , RelConceptDef(..), P_Declaration(..)
+   , Term(..), TermPrim(..)
+   , PairView(..), PairViewSegment(..), PairViewTerm(..), PairViewSegmentTerm(..)
+   , SrcOrTgt(..), isSrc
+   , P_Rule(..)
+   , ConceptDef(..)
+   , P_Population(..)
+   
+   , P_ObjectDef, P_SubInterface, P_Interface(..), P_ObjDef(..), P_SubIfc(..)
+   
+   , P_IdentDef(..) , P_IdentSegment(..)
+   , P_ViewDef , P_ViewSegment
+   , P_ViewD(..) , P_ViewSegmt(..)
+   
+   , PPurpose(..),PRef2Obj(..),PMeaning(..),PMessage(..)
+   
+   , P_Concept(..), P_Sign(..)
+   
+   , P_Gen(..)
+   
+   , Lang(..)
+   , P_Markup(..)
+   
+   , PandocFormat(..)
+   
+   , Label(..)
+   
+   , Prop(..), Props
+   -- Inherited stuff: 
+   , module DatabaseDesign.Ampersand.Input.ADL1.FilePos
+   , module DatabaseDesign.Ampersand.ADL1.Pair
+   , gen_concs
+  )
+where
+   import DatabaseDesign.Ampersand.Input.ADL1.FilePos           
+   import DatabaseDesign.Ampersand.Basics
+   import DatabaseDesign.Ampersand.ADL1.Pair (Pairs,Paire,mkPair ,srcPaire, trgPaire)
+   import Data.Traversable
+   import Data.Foldable
+   import Prelude hiding (foldr, sequence)
+   import Control.Applicative
+
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Core.ParseTree"
+   
+   data P_Context
+      = PCtx{ ctx_nm ::     String           -- ^ The name of this context
+            , ctx_pos ::    [Origin]         -- ^ The origin of the context. A context can be a merge of a file including other files c.q. a list of Origin.
+            , ctx_lang ::   Maybe Lang       -- ^ The default language specified by this context, if specified at all.
+            , ctx_markup :: Maybe PandocFormat  -- ^ The default markup format for free text in this context
+            , ctx_thms ::   [String]         -- ^ Names of patterns/processes to be printed in the functional specification. (For partial documents.)
+            , ctx_pats ::   [P_Pattern]      -- ^ The patterns defined in this context
+            , ctx_PPrcs ::  [P_Process]      -- ^ The processes as defined by the parser
+            , ctx_rs ::     [(P_Rule TermPrim)]         -- ^ All user defined rules in this context, but outside patterns and outside processes
+            , ctx_ds ::     [P_Declaration]  -- ^ The declarations defined in this context, outside the scope of patterns
+            , ctx_cs ::     [ConceptDef]     -- ^ The concept definitions defined in this context, outside the scope of patterns
+            , ctx_ks ::     [P_IdentDef]     -- ^ The identity definitions defined in this context, outside the scope of patterns
+            , ctx_vs ::     [P_ViewDef]      -- ^ The view definitions defined in this context, outside the scope of patterns
+            , ctx_gs ::     [P_Gen]          -- ^ The gen definitions defined in this context, outside the scope of patterns
+            , ctx_ifcs ::   [P_Interface]    -- ^ The interfaces defined in this context, outside the scope of patterns
+            , ctx_ps ::     [PPurpose]       -- ^ The purposes defined in this context, outside the scope of patterns
+            , ctx_pops ::   [P_Population]   -- ^ The populations defined in this context
+            , ctx_sql ::    [P_ObjectDef]    -- ^ user defined sqlplugs, taken from the Ampersand script
+            , ctx_php ::    [P_ObjectDef]    -- ^ user defined phpplugs, taken from the Ampersand script
+            , ctx_metas ::  [Meta]         -- ^ generic meta information (name/value pairs) that can be used for experimenting without having to modify the adl syntax
+            } deriving Show
+   
+   instance Eq P_Context where
+     c1 == c2  =  name c1 == name c2
+   
+   instance Identified P_Context where
+     name = ctx_nm
+   
+   -- for declaring name/value pairs with information that is built in to the adl syntax yet
+   data Meta = Meta { mtPos :: Origin
+                 , mtObj :: MetaObj
+                 , mtName :: String
+                 , mtVal :: String
+                 } deriving (Show)
+   data MetaObj = ContextMeta deriving Show -- for now, we just have meta data for the entire context  
+   
+   -- | A RoleRelation rs means that any role in 'rrRoles rs' may edit any Relation  in  'rrInterfaces rs'
+   data P_RoleRelation
+      = P_RR { rr_Roles :: [String]  -- ^ name of a role
+             , rr_Rels :: [TermPrim] -- ^ Typically: PTrel nm sgn, with nm::String and sgn::P_Sign representing a Relation with type information
+             , rr_Pos :: Origin      -- ^ position in the Ampersand script
+             } deriving (Show)       -- deriving Show is just for debugging
+   instance Eq P_RoleRelation where rr==rr' = origin rr==origin rr'
+   instance Traced P_RoleRelation where
+    origin = rr_Pos
+
+   data P_Process
+      = P_Prc { procNm :: String
+              , procPos :: Origin             -- ^ the start position in the file
+              , procEnd :: Origin             -- ^ the end position in the file
+              , procRules :: [(P_Rule TermPrim)]         -- ^ the rules in this process
+              , procGens :: [P_Gen]           -- ^ the generalizations in this process
+              , procDcls :: [P_Declaration]   -- ^ the relation declarations in this process
+              , procRRuls :: [RoleRule]       -- ^ The assignment of roles to rules.
+              , procRRels :: [P_RoleRelation] -- ^ The assignment of roles to Relations.
+              , procCds :: [ConceptDef]       -- ^ The concept definitions defined in this process
+              , procIds :: [P_IdentDef]       -- ^ The identity definitions defined in this process
+              , procVds :: [P_ViewDef]        -- ^ The view definitions defined in this process
+              , procXps :: [PPurpose]         -- ^ The purposes of elements defined in this process
+              , procPop :: [P_Population]     -- ^ The populations that are local to this process
+              } deriving Show
+
+   instance Identified P_Process where
+    name = procNm 
+
+   instance Traced P_Process where
+    origin = procPos
+
+    -- | A RoleRule r means that a role called 'mRoles r' must maintain the process rule called 'mRules r'
+   data RoleRule
+      = Maintain
+        { mRoles :: [String]    -- ^ name of a role
+        , mRules :: [String]    -- ^ name of a Rule
+        , mPos :: Origin      -- ^ position in the Ampersand script
+        } deriving (Eq, Show)   -- deriving (Eq, Show) is just for debugging
+
+   instance Traced RoleRule where
+    origin = mPos
+
+   data P_Pattern
+      = P_Pat { pt_nm :: String            -- ^ Name of this pattern
+              , pt_pos :: Origin           -- ^ the starting position in the file in which this pattern was declared.
+              , pt_end :: Origin           -- ^ the end position in the file in which this pattern was declared.
+              , pt_rls :: [(P_Rule TermPrim)]         -- ^ The user defined rules in this pattern
+              , pt_gns :: [P_Gen]          -- ^ The generalizations defined in this pattern
+              , pt_dcs :: [P_Declaration]  -- ^ The declarations declared in this pattern
+              , pt_rus :: [RoleRule]       -- ^ The assignment of roles to rules.
+              , pt_res :: [P_RoleRelation] -- ^ The assignment of roles to Relations.
+              , pt_cds :: [ConceptDef]     -- ^ The concept definitions defined in this pattern
+              , pt_ids :: [P_IdentDef]     -- ^ The identity definitions defined in this pattern
+              , pt_vds :: [P_ViewDef]      -- ^ The view definitions defined in this pattern
+              , pt_xps :: [PPurpose]       -- ^ The purposes of elements defined in this pattern
+              , pt_pop :: [P_Population]   -- ^ The populations that are local to this pattern
+              }   deriving (Show)       -- for debugging purposes
+
+   instance Identified P_Pattern where
+    name = pt_nm
+
+   instance Traced P_Pattern where
+    origin = pt_pos
+
+   data ConceptDef 
+      = Cd  { cdpos :: Origin   -- ^ The position of this definition in the text of the Ampersand source (filename, line number and column number).
+            , cdcpt :: String   -- ^ The name of the concept for which this is the definition. If there is no such concept, the conceptdefinition is ignored.
+            , cdplug:: Bool     -- ^ Whether the user specifically told Ampersand not to store this concept in the database
+            , cddef :: String   -- ^ The textual definition of this concept.
+            , cdtyp :: String   -- ^ The type of this concept.
+            , cdref :: String   -- ^ A label meant to identify the source of the definition. (useful as LaTeX' symbolic reference)
+            }   deriving (Show,Eq)
+
+-- \***********************************************************************
+-- \*** Eigenschappen met betrekking tot: ConceptDef                    ***
+-- \***********************************************************************
+ --  instance Show ConceptDef
+   instance Traced ConceptDef where
+    origin = cdpos
+   instance Identified ConceptDef where
+    name = cdcpt
+   
+   data RelConceptDef = RelConceptDef SrcOrTgt String deriving (Eq, Show)
+   
+   data P_Declaration = 
+         P_Sgn { dec_nm :: String    -- ^ the name of the declaration
+               , dec_sign :: P_Sign    -- ^ the type. Parser must guarantee it is not empty.
+               , dec_prps :: Props     -- ^ the user defined multiplicity properties (Uni, Tot, Sur, Inj) and algebraic properties (Sym, Asy, Trn, Rfx)
+               , dec_prL :: String    -- ^ three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas."
+               , dec_prM :: String    -- ^    then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas.
+               , dec_prR :: String
+               , dec_Mean :: [PMeaning]  -- ^ the optional meaning of a declaration, possibly more than one for different languages.
+               , dec_conceptDef :: Maybe RelConceptDef -- ^ alternative definition for the source or target concept in the context of this relation
+               , dec_popu :: Pairs     -- ^ the list of tuples, of which the relation consists.
+               , dec_fpos :: Origin    -- ^ the position in the Ampersand source file where this declaration is declared. Not all decalartions come from the ampersand souce file. 
+               , dec_plug :: Bool      -- ^ if true, this relation may not be stored in or retrieved from the standard database (it should be gotten from a Plug of some sort instead)
+               } deriving Show -- for debugging and testing only
+   instance Eq P_Declaration where
+    decl==decl' = origin decl==origin decl'
+   instance Prelude.Ord P_Declaration where
+    decl `compare` decl' = origin decl `compare` origin decl'
+   instance Identified P_Declaration where
+    name = dec_nm
+   instance Traced P_Declaration where
+    origin = dec_fpos
+   
+   data TermPrim
+      = PI Origin                              -- ^ identity element without a type
+                                               --   At parse time, there may be zero or one element in the list of concepts.
+                                               --   Reason: when making eqClasses, the least element of that class is used as a witness of that class
+                                               --   to know whether an eqClass represents a concept, we only look at its witness
+                                               --   By making Pid the first in the data decleration, it becomes the least element for "deriving Ord".
+      | Pid Origin P_Concept                   -- ^ identity element restricted to a type
+      | Patm Origin String (Maybe P_Concept)   -- ^ an atom, possibly with a type
+      | PVee Origin                            -- ^ the complete relation, of which the type is yet to be derived by the type checker.
+      | Pfull Origin P_Concept P_Concept       -- ^ the complete relation, restricted to a type.
+                                               --   At parse time, there may be zero, one or two elements in the list of concepts.
+      | Prel Origin String                     -- ^ we expect expressions in flip-normal form
+      | PTrel Origin String P_Sign             -- ^ type cast expression 
+      deriving Show
+   data Term a
+      = Prim a
+      | Pequ Origin (Term a) (Term a)  -- ^ equivalence             =
+      | Pimp Origin (Term a) (Term a)  -- ^ implication             |-
+      | PIsc Origin (Term a) (Term a)  -- ^ intersection            /\
+      | PUni Origin (Term a) (Term a)  -- ^ union                   \/
+      | PDif Origin (Term a) (Term a)  -- ^ difference              -
+      | PLrs Origin (Term a) (Term a)  -- ^ left residual           /
+      | PRrs Origin (Term a) (Term a)  -- ^ right residual          \
+      | PCps Origin (Term a) (Term a)  -- ^ composition             ;
+      | PRad Origin (Term a) (Term a)  -- ^ relative addition       !
+      | PPrd Origin (Term a) (Term a)  -- ^ cartesian product       *
+      | PKl0 Origin (Term a)           -- ^ Rfx.Trn closure         *  (Kleene star)
+      | PKl1 Origin (Term a)           -- ^ Transitive closure      +  (Kleene plus)
+      | PFlp Origin (Term a)           -- ^ conversion (flip, wok)  ~
+      | PCpl Origin (Term a)           -- ^ Complement
+      | PBrk Origin (Term a)           -- ^ bracketed expression ( ... )
+      deriving (Show) -- deriving Show for debugging purposes
+   instance Functor Term where fmap = fmapDefault
+   instance Foldable Term where foldMap = foldMapDefault
+   instance Traversable Term where
+    traverse f' x
+     = case x of
+       Prim a -> Prim <$> f' a
+       Pequ o a b -> Pequ o <$> (f a) <*> (f b)
+       Pimp o a b -> Pimp o <$> (f a) <*> (f b)
+       PIsc o a b -> PIsc o <$> (f a) <*> (f b)
+       PUni o a b -> PUni o <$> (f a) <*> (f b)
+       PDif o a b -> PDif o <$> (f a) <*> (f b)
+       PLrs o a b -> PLrs o <$> (f a) <*> (f b)
+       PRrs o a b -> PRrs o <$> (f a) <*> (f b)
+       PCps o a b -> PCps o <$> (f a) <*> (f b)
+       PRad o a b -> PRad o <$> (f a) <*> (f b)
+       PPrd o a b -> PPrd o <$> (f a) <*> (f b)
+       PKl0 o a   -> PKl0 o <$> (f a)
+       PKl1 o a   -> PKl1 o <$> (f a)
+       PFlp o a   -> PFlp o <$> (f a)
+       PCpl o a   -> PCpl o <$> (f a)
+       PBrk o a   -> PBrk o <$> (f a)
+     where f = traverse f'
+   
+   
+   instance Functor P_SubIfc where fmap = fmapDefault
+   instance Foldable P_SubIfc where foldMap = foldMapDefault
+   instance Traversable P_SubIfc where
+    traverse _ (P_InterfaceRef a b) = pure (P_InterfaceRef a b)
+    traverse f (P_Box b lst) = P_Box b <$> (traverse (traverse f) lst)
+   
+   instance Traced (P_SubIfc a) where
+    origin = si_ori
+   
+   instance Functor P_ObjDef where fmap = fmapDefault
+   instance Foldable P_ObjDef where foldMap = foldMapDefault
+   instance Traversable P_ObjDef where
+    traverse f (P_Obj nm pos ctx msub strs)
+     = (\ctx' msub'->(P_Obj nm pos ctx' msub' strs)) <$>
+        traverse f ctx <*> traverse (traverse f) msub
+   
+   instance Traced TermPrim where
+    origin e = case e of
+      PI orig        -> orig
+      Pid orig _     -> orig
+      Patm orig _ _  -> orig
+      PVee orig      -> orig
+      Pfull orig _ _ -> orig
+      Prel orig _    -> orig
+      PTrel orig _ _ -> orig
+   instance Identified TermPrim where
+    name e = case e of
+      PI _        -> "I"
+      Pid _ _     -> "I"
+      Patm _ s _  -> s
+      PVee _      -> "V"
+      Pfull _ _ _ -> "V"
+      Prel _ r    -> r
+      PTrel _ r _ -> r
+      
+   instance Traced a => Traced (Term a) where
+    origin e = case e of
+      Prim a         -> origin a
+      Pequ orig _ _  -> orig
+      Pimp orig _ _  -> orig
+      PIsc orig _ _  -> orig
+      PUni orig _ _  -> orig
+      PDif orig _ _  -> orig
+      PLrs orig _ _  -> orig
+      PRrs orig _ _  -> orig
+      PCps orig _ _  -> orig
+      PRad orig _ _  -> orig
+      PPrd orig _ _  -> orig
+      PKl0 orig _    -> orig
+      PKl1 orig _    -> orig
+      PFlp orig _    -> orig
+      PCpl orig _    -> orig
+      PBrk orig _    -> orig
+
+   data SrcOrTgt = Src | Tgt deriving (Show, Eq, Ord)
+   instance Flippable SrcOrTgt where
+     flp Src = Tgt
+     flp Tgt = Src
+   
+   isSrc :: SrcOrTgt -> Bool
+   isSrc Src = True
+   isSrc Tgt = False
+   
+   data PairView a = PairView { ppv_segs :: [PairViewSegment a] } deriving Show
+   data PairViewSegment a = PairViewText String
+                          | PairViewExp SrcOrTgt a
+            deriving Show
+   -- | the newtype to make it possible for a PairView to be disambiguatable: it must be of the form "d a" instead of "d (Term a)"
+   newtype PairViewTerm a = PairViewTerm (PairView (Term a)) 
+   newtype PairViewSegmentTerm a = PairViewSegmentTerm (PairViewSegment (Term a))
+   
+   instance Traversable PairViewSegmentTerm where
+     traverse f (PairViewSegmentTerm x) = PairViewSegmentTerm <$> traverse (traverse f) x
+   instance Functor PairViewSegmentTerm where fmap = fmapDefault
+   instance Foldable PairViewSegmentTerm where foldMap = foldMapDefault
+   instance Traversable PairViewTerm where
+     traverse f (PairViewTerm x) = PairViewTerm <$> traverse (traverse f) x
+   instance Functor PairViewTerm where fmap = fmapDefault
+   instance Foldable PairViewTerm where foldMap = foldMapDefault
+   instance Traversable PairViewSegment where
+     traverse _ (PairViewText s) = pure (PairViewText s)
+     traverse f (PairViewExp st x) = PairViewExp st <$> f x
+   instance Functor PairViewSegment where fmap = fmapDefault
+   instance Foldable PairViewSegment where foldMap = foldMapDefault
+   instance Traversable PairView where
+     traverse f (PairView s) = PairView <$> traverse (traverse f) s
+   instance Functor PairView where fmap = fmapDefault
+   instance Foldable PairView where foldMap = foldMapDefault
+   
+   
+   data P_Rule a  =
+      P_Ru { rr_nm ::   String            -- ^ Name of this rule
+           , rr_exp ::  (Term a)   -- ^ The rule expression 
+           , rr_fps ::  Origin            -- ^ Position in the Ampersand file
+           , rr_mean :: [PMeaning]        -- ^ User-specified meanings, possibly more than one, for multiple languages.
+           , rr_msg ::  [PMessage]        -- ^ User-specified violation messages, possibly more than one, for multiple languages.
+           , rr_viol :: Maybe (PairView (Term a))  -- ^ Custom presentation for violations, currently only in a single language
+           } deriving Show
+
+   instance Traced (P_Rule a) where
+    origin = rr_fps
+   instance Functor P_Rule where fmap = fmapDefault
+   instance Foldable P_Rule where foldMap = foldMapDefault
+   instance Traversable P_Rule where
+    traverse f (P_Ru nm expr fps mean msg viol)
+     = (\e v -> P_Ru nm e fps mean msg v) <$> traverse f expr <*> traverse (traverse (traverse f)) viol
+
+   instance Identified (P_Rule a) where
+    name = rr_nm
+
+   newtype PMeaning = PMeaning P_Markup
+            deriving Show
+   newtype PMessage = PMessage P_Markup
+            deriving Show
+   data P_Markup = 
+       P_Markup  { mLang ::   Maybe Lang
+                 , mFormat :: Maybe PandocFormat
+                 , mString :: String
+                 } deriving Show -- for debugging only     
+               
+   data P_Population
+     = P_RelPopu { p_rnme ::  String  -- the name of a relation
+                 , p_orig ::  Origin  -- the origin 
+                 , p_popps :: Pairs   -- the contents
+                 }
+     | P_TRelPop { p_rnme ::  String  -- the name of a relation
+                 , p_type ::  P_Sign  -- the sign of the relation
+                 , p_orig ::  Origin  -- the origin 
+                 , p_popps :: Pairs   -- the contents
+                 }
+     | P_CptPopu { p_cnme ::  String  -- the name of a concept
+                 , p_orig ::  Origin  -- the origin
+                 , p_popas :: [String]   -- atoms in the initial population of that concept
+                 }
+       deriving Show
+       
+   instance Identified P_Population where
+    name P_RelPopu{p_rnme = nm} = nm
+    name P_TRelPop{p_rnme = nm} = nm
+    name P_CptPopu{p_cnme = nm} = nm
+    
+   instance Traced P_Population where
+    origin = p_orig
+
+   data P_Interface = 
+        P_Ifc { ifc_Name :: String           -- ^ the name of the interface
+              , ifc_Params :: [TermPrim]         -- ^ a list of relations, which are editable within this interface.
+                                             --   either   Prel o nm
+                                             --       or   PTrel o nm sgn
+              , ifc_Args :: [[String]]       -- ^ a list of arguments for code generation.
+              , ifc_Roles :: [String]        -- ^ a list of roles that may use this interface
+              , ifc_Obj :: P_ObjectDef       -- ^ the context expression (mostly: I[c])
+              , ifc_Pos :: Origin
+              , ifc_Prp :: String
+              } deriving Show
+
+   instance Identified P_Interface where
+    name = ifc_Name
+
+   instance Traced P_Interface where
+    origin = ifc_Pos
+   
+   type P_SubInterface = P_SubIfc TermPrim
+   data P_SubIfc a
+                 = P_Box          { si_ori :: Origin
+                                  , si_box :: [P_ObjDef a] }
+                 | P_InterfaceRef { si_ori :: Origin
+                                  , si_str :: String }
+                   deriving (Eq, Show)
+
+   type P_ObjectDef = P_ObjDef TermPrim
+   data P_ObjDef a = 
+        P_Obj { obj_nm :: String         -- ^ view name of the object definition. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface if it is not an empty string.
+              , obj_pos :: Origin         -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number)
+              , obj_ctx :: Term a        -- ^ this expression describes the instances of this object, related to their context. 
+              , obj_msub :: Maybe (P_SubIfc a)  -- ^ the attributes, which are object definitions themselves.
+              , obj_strs :: [[String]]     -- ^ directives that specify the interface.
+              }  deriving (Show)       -- just for debugging (zie ook instance Show ObjectDef)
+   instance Eq (P_ObjDef a) where od==od' = origin od==origin od'
+   instance Identified (P_ObjDef a) where
+    name = obj_nm
+   instance Traced (P_ObjDef a) where
+    origin = obj_pos
+
+   data P_IdentDef =
+            P_Id { ix_pos :: Origin         -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number).
+                 , ix_lbl :: String         -- ^ the name (or label) of this Identity. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface. It is not an empty string.
+                 , ix_cpt :: P_Concept      -- ^ this expression describes the instances of this object, related to their context
+                 , ix_ats :: [P_IdentSegment] -- ^ the constituent segments of this identity. TODO: refactor to a list of terms
+                 } deriving (Show)
+   instance Identified P_IdentDef where
+    name = ix_lbl
+   instance Eq P_IdentDef where identity==identity' = origin identity==origin identity'
+
+   instance Traced P_IdentDef where
+    origin = ix_pos
+   
+   data P_IdentSegment 
+                 = P_IdentExp  { ks_obj :: P_ObjectDef }
+                   deriving (Eq, Show)
+   type P_ViewDef = P_ViewD TermPrim
+   data P_ViewD a = 
+            P_Vd { vd_pos :: Origin         -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number).
+                 , vd_lbl :: String         -- ^ the name (or label) of this View. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface. It is not an empty string.
+                 , vd_cpt :: P_Concept      -- ^ this expression describes the instances of this object, related to their context
+                 , vd_ats :: [P_ViewSegmt a] -- ^ the constituent segments of this view.
+                 } deriving (Show)
+   instance Identified (P_ViewD a) where
+    name = vd_lbl
+   instance Functor P_ViewD where fmap = fmapDefault
+   instance Foldable P_ViewD where foldMap = foldMapDefault
+   instance Traversable P_ViewD where
+    traverse f (P_Vd a b c d) = P_Vd a b c <$> traverse (traverse f) d
+   
+   instance Functor P_ViewSegmt where fmap = fmapDefault
+   instance Foldable P_ViewSegmt where foldMap = foldMapDefault
+   instance Traversable P_ViewSegmt where
+    traverse f (P_ViewExp  a) = P_ViewExp <$> traverse f a
+    traverse _ (P_ViewText a) = pure (P_ViewText a)
+    traverse _ (P_ViewHtml a) = pure (P_ViewHtml a)
+   
+   instance Traced (P_ViewD a) where
+    origin = vd_pos
+   
+   type P_ViewSegment = P_ViewSegmt TermPrim
+   data P_ViewSegmt a 
+                 = P_ViewExp  { vs_obj :: P_ObjDef a }
+                 | P_ViewText { vs_txt :: String }
+                 | P_ViewHtml { vs_htm :: String }
+                   deriving (Eq, Show)
+                  
+-- PPurpose is a parse-time constructor. It contains the name of the object it explains.
+-- It is a pre-explanation in the sense that it contains a reference to something that is not yet built by the compiler.
+--                       Constructor      name          RefID  Explanation
+   data PRef2Obj = PRef2ConceptDef String
+                 | PRef2Declaration TermPrim -- typically PTrel o nm sgn,   with nm::String and sgn::P_Sign
+                                         -- or        Prel o nm; Other terms become fatals
+                 | PRef2Rule String
+                 | PRef2IdentityDef String
+                 | PRef2ViewDef String
+                 | PRef2Pattern String
+                 | PRef2Process String
+                 | PRef2Interface String
+                 | PRef2Context String
+                 | PRef2Fspc String
+                 deriving Show -- only for fatal error messages
+   
+   instance Identified PRef2Obj where
+     name pe = case pe of 
+        PRef2ConceptDef str -> str
+        PRef2Declaration (PTrel _ nm sgn) -> nm++show sgn
+        PRef2Declaration (Prel _ nm) -> nm
+        PRef2Declaration expr -> fatal 362 ("Expression "++show expr++" should never occur in PRef2Declaration")
+        PRef2Rule str -> str
+        PRef2IdentityDef str -> str
+        PRef2ViewDef str -> str
+        PRef2Pattern str -> str
+        PRef2Process str -> str
+        PRef2Interface str -> str
+        PRef2Context str -> str
+        PRef2Fspc str -> str
+
+   data PPurpose = PRef2 { pexPos :: Origin     -- the position in the Ampersand script of this purpose definition
+                         , pexObj :: PRef2Obj   -- the reference to the object whose purpose is explained
+                         , pexMarkup:: P_Markup   -- the piece of text, including markup and language info
+                         , pexRefID :: String     -- the reference (for traceability)
+                         } deriving Show
+
+   instance Identified PPurpose where
+    name pe = name (pexObj pe)
+
+   instance Traced PPurpose where
+    origin = pexPos
+
+   data P_Concept
+      = PCpt{ p_cptnm :: String }  -- ^The name of this Concept
+      | P_Singleton 
+--      deriving (Eq, Ord)
+-- (Sebastiaan 12 feb 2012) P_Concept has been defined Ord, only because we want to maintain sets of concepts in the type checker for quicker lookups.
+-- (Sebastiaan 11 okt 2013) Removed this again, I thought it would be more clean to use newtype for this instead
+
+   instance Identified P_Concept where
+    name (PCpt {p_cptnm = nm}) = nm
+    name P_Singleton = "ONE"
+   
+   instance Show P_Concept where
+    showsPrec _ c = showString (name c)
+
+
+   data P_Sign = P_Sign {pSrc :: P_Concept, pTrg :: P_Concept }
+
+   instance Show P_Sign where
+     showsPrec _ sgn = 
+         showString (   "[" ++ show (pSrc sgn)++"*"++show (pTrg sgn) ++ "]" )
+
+   data P_Gen =  P_Cy{ gen_spc :: P_Concept         -- ^ Left hand side concept expression 
+                     , gen_rhs :: [P_Concept]       -- ^ Right hand side concept expression
+                     , gen_fp ::  Origin            -- ^ Position in the Ampersand file
+                     }
+               | PGen{ gen_spc :: P_Concept      -- ^ specific concept
+                     , gen_gen :: P_Concept      -- ^ generic concept
+                     , gen_fp  :: Origin         -- ^ the position of the GEN-rule
+                     }
+   gen_concs :: P_Gen -> [P_Concept]
+   gen_concs (P_Cy {gen_rhs=x}) = x
+   gen_concs (PGen {gen_gen=x,gen_spc=y}) = [x,y]
+      
+   instance Show P_Gen where
+    -- This show is used in error messages.
+    showsPrec _ g = showString ("CLASSIFY "++show (gen_spc g)++" IS "++show (gen_concs g))
+
+   instance Traced P_Gen where
+    origin = gen_fp
+
+   data Lang = Dutch | English deriving (Show, Eq)
+
+   data PandocFormat = HTML | ReST | LaTeX | Markdown deriving (Eq, Show)
+
+   type Props = [Prop]
+
+   data Prop      = Uni          -- ^ univalent
+                  | Inj          -- ^ injective
+                  | Sur          -- ^ surjective
+                  | Tot          -- ^ total
+                  | Sym          -- ^ symmetric
+                  | Asy          -- ^ antisymmetric
+                  | Trn          -- ^ transitive
+                  | Rfx          -- ^ reflexive
+                  | Irf          -- ^ irreflexive
+                    deriving (Eq,Ord)
+   instance Show Prop where
+    showsPrec _ Uni = showString "UNI"
+    showsPrec _ Inj = showString "INJ"
+    showsPrec _ Sur = showString "SUR"
+    showsPrec _ Tot = showString "TOT"
+    showsPrec _ Sym = showString "SYM"
+    showsPrec _ Asy = showString "ASY"
+    showsPrec _ Trn = showString "TRN"
+    showsPrec _ Rfx = showString "RFX"
+    showsPrec _ Irf = showString "IRF"
+
+   instance Flippable Prop where
+    flp Uni = Inj
+    flp Tot = Sur
+    flp Sur = Tot
+    flp Inj = Uni
+    flp x = x
+
+   data Label = Lbl { lblnm :: String
+                    , lblpos :: Origin
+                    , lblstrs :: [[String]]
+                    }
+   instance Eq Label where
+    l==l' = lblnm l==lblnm l'
+
+ src/lib/DatabaseDesign/Ampersand/Core/Poset.hs view
@@ -0,0 +1,136 @@+{- COPIED FROM http://hackage.haskell.org/package/altfloat-0.3.1 -}+{-+ - Copyright (C) 2009 Nick Bowler.+ -+ - License BSD2:  2-clause BSD license.  See LICENSE for full terms.+ - This is free software: you are free to change and redistribute it.+ - There is NO WARRANTY, to the extent permitted by law.+ -}++-- | Partially ordered data types.  The standard 'Prelude.Ord' class is for+-- total orders and therefore not suitable for floating point.  However, we can+-- still define meaningful 'max' and 'sortWith functions for these types.+--+-- We define our own 'Ord' class which is intended as a replacement for+-- 'Prelude.Ord'.  Should the user wish to take advantage of existing libraries+-- which use 'Prelude.Ord', just let Prelude.compare = (totalOrder .) . compare+module DatabaseDesign.Ampersand.Core.Poset (+    Poset(..), Sortable(..), Ordering(..), Ord, comparableClass,greatest,least,maxima,minima,sortWith+) where+import qualified Prelude+import qualified GHC.Exts (sortWith)++import Prelude hiding (Ord(..), Ordering(..))+import DatabaseDesign.Ampersand.Basics+import DatabaseDesign.Ampersand.Core.Poset.Instances+import DatabaseDesign.Ampersand.Core.Poset.Internal hiding (fatal)++import Data.Function+import Data.Monoid++import DatabaseDesign.Ampersand.Basics (eqCl,isc,fatalMsg)+import qualified Data.List as List++fatal :: Int -> String -> a+fatal = fatalMsg "Core.Poset"++-- | makePartialOrder makes a partial order containing local partial orders, i.e. comparable classes.+--   it makes sense to sort comparable classes.+--   example: A and B are in a comparable class+--            A and B are not LT, not GT, not EQ => CP+--            if you sortBy comparableClass then A and B are considered EQ (comparableClass CP = Prelude.EQ)+--   when the comparable classes have a top, then join can be defined on them+--   when the comparable classes have a bottom, then meet can be defined on them+--+--   When A_Concept should be a collection of total orders change f a b guard (| or [ a `elem` cl && b `elem` cl | cl <- cls ] = NC)+--+--   examples on data X = A | B | C | D | E | F deriving (Eq,Show):+--   [bottom]       (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(D,E),(D,F)]) :: (A <= B /\ C <= B \/ C <= D <= E /\ F <= E \/ F)+--   [ringish]      (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(D,E),(D,F),(E,A),(F,A)]) _ _ = LT +--   [ringish]      (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(D,E),(D,F),(E,A)])       F A = GT+--                  (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(D,E),(D,F),(E,A)])       _ _ = LT+--   [bottom,total] (makePartialOrder [(A,B),(C,D),(B,D),(A,C),(E,F)]) :: ( A <= B /\ C <= B \/ C <= D , E <= F )+--   [2x total]     (makePartialOrder [(A,B),(B,C),(C,D),(E,F)]) :: ( A <= B <= C <= D , E <= F )+--   [total]        (makePartialOrder [(A,B),(B,C),(C,D),(D,E),(E,F)]) :: ( A <= B <= C <= D <= E <= F )+--   [3x total]     (makePartialOrder [(A,B),(B,C),(C,D)]) :: ( A <= B <= C <= D , E , F )+--   [partial]      (makePartialOrder [(A,B),(C,D),(B,D),(D,E),(D,F)]) :: ( (A <= B <= D <= E /\ F <= E \/ F) + (C <= D <= E /\ F <= E \/ F) ) +--+--   a sorted list will have the x left of y for all x and y. x <= y+--   like x==y, the intraposition of x and y is without meaning for all x and y. x `compare` y = CP+--   for example given a (makePartialOrder [(A,B),(C,D),(B,D),(D,E),(F,C)]):+--    + sort  [F,E,D,C,B,A] = [F,C,A,B,D,E]+--    + sort  [F,E,D,B,A,C] = [F,A,B,C,D,E]+--    + sort  [B,F,E,C,D,A] = [A,B,F,C,D,E]+++instance Poset a => Poset (Maybe a) where+    Just x  <= Just y = x <= y+    Nothing <= _      = True+    _       <= _      = False++instance Poset a => Poset [a] where+    compare = (mconcat .) . zipWith compare++-- | Sort a list using the default comparison function.+sort :: Sortable a => [a] -> [a]+sort = sortBy compare++-- | Apply a function to values before comparing.+comparing :: Poset b => (a -> b) -> a -> a -> Ordering+comparing = on compare++-- example where b=A_Concept: sortWith (snd . order , concs fSpec) idCpt (vIndices fSpec)+sortWith :: (Show b,Poset b) => (b -> [[b]], [b]) -> (a -> b) -> [a] -> [a]+sortWith _   _  [] = [] +sortWith (tos,allb) f xs + = let xtos = [ [x | x<-xs, elem (f x) to] --group xs such that each elem of (map f xtos) is a total order+              | to<-(tos . f . head) xs --non-trivial total orders+                    ++ [[b] | b<-allb, not( elem b (concat((tos . f . head) xs))) ] --trivial total orders+              ] +       sortwith = List.sortBy (\x y -> comparableClass(compare (f x) (f y))) --sortwith of Poset, which should be a total order+   in  concat(map sortwith xtos) --sortwith each total order and concat them         ++-- | Elements can be arranged into classes of comparable elements, not necessarily a total order+--   It makes sense to sort such a class.+--   Take for example instance Sortable A_Concept.+--   When A_Concept should be a collection of total orders: comparableClass CP = fatal 118 "Elements in totally ordered class, which are not LT, not GT and not EQ."+comparableClass :: Ordering -> Prelude.Ordering+comparableClass LT = Prelude.LT+comparableClass EQ = Prelude.EQ+comparableClass GT = Prelude.GT+comparableClass NC = fatal 123 "Uncomparable elements in comparable class."+comparableClass CP = Prelude.EQ --the position of two comparable concepts is equal++-- | If elements are in a total order, then they can be sortedBy totalOrder using the Prelude.Ordering+--   When A_Concept should be in a total order with an Anything and Nothing: sortBy f = Data.List.sortBy ((totalOrder .) . f)+totalOrder :: Ordering -> Prelude.Ordering+totalOrder LT = Prelude.LT+totalOrder EQ = Prelude.EQ+totalOrder GT = Prelude.GT+totalOrder NC = fatal 132 "Uncomparable elements in total order."+totalOrder CP = fatal 133 "Uncomparable elements in total order."++-- | takes the greatest a of comparables+greatest :: (Show a,Sortable a) => [a] -> a+greatest xs =+  case maxima (List.nub xs) of+    []  -> fatal 138 "there is no greatest"+    [x] -> x+    xs  -> fatal 140 ("there is more than one greatest: "++ show (List.nub xs))+-- | takes all a without anything larger+maxima :: Sortable a => [a] -> [a]+maxima [] = fatal 144 "the empty list has no maximum"+maxima xs = [x | x<-List.nub xs,not (or [x < y | y<-List.nub xs])]++-- | takes the least a of comparables if there is only one+least :: Sortable a => [a] -> a+least xs =+  case minima (List.nub xs) of+    []  -> fatal 150 "there is no least"+    [x] -> x+    xs  -> fatal 150 "there is more than one least. "+-- | takes all a without anything less+minima :: Sortable a => [a] -> [a]+minima [] = fatal 156 "the empty list has no minimum"+minima xs = [x | x<-List.nub xs,not (or [y < x | y<-List.nub xs])]+
+ src/lib/DatabaseDesign/Ampersand/Core/Poset/Instances.hs view
@@ -0,0 +1,57 @@+{- COPIED FROM http://hackage.haskell.org/package/altfloat-0.3.1+ - Disabled Sortable instances for instances of Prelude.Ord -}+{-+ - Copyright (C) 2009-2010 Nick Bowler.+ -+ - License BSD2:  2-clause BSD license.  See LICENSE for full terms.+ - This is free software: you are free to change and redistribute it.+ - There is NO WARRANTY, to the extent permitted by law.+ -}++-- | 'Poset' and 'Sortable' instances for instances of 'Prelude.Ord'+{-# LANGUAGE CPP #-}+module DatabaseDesign.Ampersand.Core.Poset.Instances where++import qualified DatabaseDesign.Ampersand.Core.Poset.Internal as Poset+import DatabaseDesign.Ampersand.Core.Poset.Internal (Poset, Sortable, partialOrder, totalOrder)++import Data.Ratio+import Data.List+import Data.Word+import Data.Int++#define POSET_ORD_INSTANCE(ctx, v) instance ctx Poset (v) where { \+    compare = (partialOrder .) . compare; \+    (<)     = (<); \+    (<=)    = (<=); \+    (>=)    = (>=); \+    (>)     = (>); \+    (<==>)  = const $ const True; \+    (</=>)  = const $ const False }++#define SORTABLE_ORD_INSTANCE(ctx, v) instance ctx Sortable (v) where { \+    isOrdered = const True; \+    sortBy f = sortBy $ (totalOrder .) . f; \+    max    = max; \+    min    = min; }++#define ORD_INSTANCE(ctx, v) \+    POSET_ORD_INSTANCE(ctx, v); \+ {- SORTABLE_ORD_INSTANCE(ctx, v); -} \+    instance ctx Poset.Ord (v)++ORD_INSTANCE(, Bool)+ORD_INSTANCE(, Char)+ORD_INSTANCE(, Int)+ORD_INSTANCE(, Int8)+ORD_INSTANCE(, Int16)+ORD_INSTANCE(, Int32)+ORD_INSTANCE(, Int64)+ORD_INSTANCE(, Word)+ORD_INSTANCE(, Word8)+ORD_INSTANCE(, Word16)+ORD_INSTANCE(, Word32)+ORD_INSTANCE(, Word64)+ORD_INSTANCE(, Integer)++ORD_INSTANCE(Integral a =>, Ratio a)
+ src/lib/DatabaseDesign/Ampersand/Core/Poset/Internal.hs view
@@ -0,0 +1,115 @@+{- Based on http://hackage.haskell.org/package/altfloat-0.3.1  -}+{-+ - Copyright (C) 2009-2010 Nick Bowler.+ -+ - License BSD2:  2-clause BSD license.  See LICENSE for full terms.+ - This is free software: you are free to change and redistribute it.+ - There is NO WARRANTY, to the extent permitted by law.+ -}++{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances #-}+module DatabaseDesign.Ampersand.Core.Poset.Internal where++import qualified Data.List as List+import qualified Prelude+import Prelude hiding (Ordering(..), Ord(..))+import Data.Monoid+import DatabaseDesign.Ampersand.Basics (fatalMsg)+fatal :: Int -> String -> a+fatal = fatalMsg "Core.Poset.Internal"+++data Ordering = LT | EQ | GT | CP | NC+    deriving (Eq, Show, Read, Bounded, Enum)++-- Lexicographic ordering.+instance Monoid Ordering where+    mempty = EQ+    mappend EQ x = x+    mappend NC _ = NC+    mappend LT _ = LT+    mappend GT _ = GT+    mappend CP _ = NC++-- | Internal-use function to convert our Ordering to the ordinary one.+totalOrder :: Ordering -> Prelude.Ordering+totalOrder LT = Prelude.LT+totalOrder EQ = Prelude.EQ+totalOrder GT = Prelude.GT+totalOrder NC = fatal 36 "Uncomparable elements in total order."+totalOrder CP = fatal 37 "Uncomparable elements in total order."++-- | Internal-use function to convert the ordinary Ordering to ours.+partialOrder :: Prelude.Ordering -> Ordering+partialOrder Prelude.LT = LT+partialOrder Prelude.EQ = EQ+partialOrder Prelude.GT = GT++-- | Class for partially ordered data types.  Instances should satisfy the+-- following laws for all values a, b and c:+--+-- * @a <= a@.+--+-- * @a <= b@ and @b <= a@ implies @a == b@.+--+-- * @a <= b@ and @b <= c@ implies @a <= c@.+--+-- But note that the floating point instances don't satisfy the first rule.+--+-- Minimal complete definition: 'compare' or '<='.+class Eq a => Poset a where+    compare :: a -> a -> Ordering+    -- | Is comparable to.+    (<==>) :: a -> a -> Bool+    -- | Is not comparable to.+    (</=>) :: a -> a -> Bool+    (<) :: a -> a -> Bool+    (<=) :: a -> a -> Bool+    (>=) :: a -> a -> Bool+    (>) :: a -> a -> Bool++    a `compare` b+        | a == b = EQ+        | a <= b && b <= a = EQ+        | a <= b = LT+        | b <= a = GT+        | otherwise = NC++    a <    b = a `compare` b == LT+    a >    b = a `compare` b == GT+    a <==> b = a `compare` b /= NC+    a </=> b = a `compare` b == NC+    a <=   b = a < b || a `compare` b == EQ+    a >=   b = a > b || a `compare` b == EQ++-- | Class for partially ordered data types where sorting makes sense.+-- This includes all totally ordered sets and floating point types.  Instances+-- should satisfy the following laws:+--+-- * The set of elements for which 'isOrdered' returns true is totally ordered.+--+-- * The max (or min) of an insignificant element and a significant element+-- is the significant one.+--+-- * The result of sorting a list should contain only significant elements.+--+-- * @max a b@ = @max b a@+--+-- * @min a b@ = @min b a@+--+-- The idea comes from floating point types, where non-comparable elements+-- (NaNs) are the exception rather than the rule.  For these types, we can+-- define 'max', 'min' and 'sortBy' to ignore insignificant elements.  Thus, a+-- sort of floating point values will discard all NaNs and order the remaining+-- elements.+--+-- Minimal complete definition: 'isOrdered'+class Poset a => Sortable a where+    sortBy :: (a -> a -> Ordering) -> [a] -> [a]+    join :: a -> a -> a+    meet :: a -> a -> a++-- | Class for totally ordered data types.  Instances should satisfy+-- @isOrdered a = True@ for all @a@.+class Poset a => Ord a+
+ src/lib/DatabaseDesign/Ampersand/Fspec.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Fspec (module X) where
+import DatabaseDesign.Ampersand.Fspec.Fspec as X 
+       (Fspc(..), FProcess(..), ECArule(..), lookupCpt, metaValues)
+import DatabaseDesign.Ampersand.Fspec.Plug as X
+       (PlugInfo(..), PlugSQL(..), SqlField(..), SqlFieldUsage(..), SqlType(..), tblcontents,
+        plugFields, requiredFields, requires, plugpath, Plugable(..),
+        showSQL, fldauto, isPlugIndex)
+import DatabaseDesign.Ampersand.Fspec.ShowHS as X
+       (ShowHS(..), ShowHSName(..), fSpec2Haskell, haskellIdentifier)
+import DatabaseDesign.Ampersand.Fspec.ShowADL as X (ShowADL(..), LanguageDependent(..))
+import DatabaseDesign.Ampersand.Fspec.ShowECA as X (showECA)
+import DatabaseDesign.Ampersand.Fspec.ShowMeatGrinder as X (meatGrinder)
+import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram as X
+       (clAnalysis, cdAnalysis, ClassDiag(..))
+import DatabaseDesign.Ampersand.Fspec.Graphic.Graphics as X
+       (Dotable(..), makePictureObj, printDotGraph, DrawingType(..))
+import DatabaseDesign.Ampersand.Fspec.Graphic.Picture as X
+       (Picture(..), PictType(..), writePicture)
+import DatabaseDesign.Ampersand.Fspec.ToFspec.Calc as X
+       (deriveProofs,showProof,showPrf)
+import DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Fspec as X
+       (makeFspec)
+import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms as X
+       (conjNF, disjNF, cfProof, simplify)
+import DatabaseDesign.Ampersand.Fspec.FPA as X
+       ( fPoints)
+import DatabaseDesign.Ampersand.Fspec.Motivations as X
+       (Meaning(..),Motivated(..))
+
+ src/lib/DatabaseDesign/Ampersand/Fspec/FPA.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Fspec.FPA 
+
+where
+   
+import DatabaseDesign.Ampersand.Misc (Lang(..))
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+import DatabaseDesign.Ampersand.Fspec.Fspec
+import DatabaseDesign.Ampersand.Classes
+
+-------------- Function Points ------------------
+
+class FPAble a where
+  fpa :: a->FPA
+  fPoints :: a ->Int
+  fPoints x = fPoints'(fpa x)
+  
+instance FPAble PlugSQL where
+  fpa x = FPA 
+    ILGV -- It is assumed that all persistent storage of information is done withing the scope of the system.
+    $
+    case x of
+      TblSQL{}    | (length.fields) x < 2 -> Eenvoudig
+                  | (length.fields) x < 6 -> Gemiddeld
+                  | otherwise             -> Moeilijk 
+      BinSQL{}    -> Gemiddeld
+      ScalarSQL{} -> Eenvoudig  
+
+instance FPAble Interface where
+  fpa x 
+     | (not.null.ifcParams) x  = FPA IF complxy  -- In case there are editeble relations, this must be an import function. 
+     | (isUni.objctx.ifcObj) x = FPA OF complxy  -- If there is max one atom, this is a simple function. 
+     | otherwise               = FPA UF complxy  -- Otherwise, it is a UF
+   
+    where 
+      complxy = case depth (ifcObj x) of
+                   0 -> Eenvoudig
+                   1 -> Eenvoudig
+                   2 -> Gemiddeld
+                   _ -> Moeilijk 
+      depth :: ObjectDef -> Int
+      depth Obj{objmsub=Nothing} = 0
+      depth Obj{objmsub=Just si}
+         = case si of
+             Box _ os       -> 1 + maximum (map depth os) 
+             InterfaceRef{} -> 1
+                  
+
+class ShowLang a where
+  showLang :: Lang -> a -> String
+
+instance ShowLang FPcompl where
+ showLang Dutch Eenvoudig   = "Eenvoudig"
+ showLang Dutch Gemiddeld   = "Gemiddeld"
+ showLang Dutch Moeilijk    = "Moeilijk"
+ showLang English Eenvoudig = "Low"
+ showLang English Gemiddeld = "Average"
+ showLang English Moeilijk  = "High"
+
+instance ShowLang FPtype where
+ showLang Dutch t = show t
+ showLang English ILGV = "ILF" -- Internal Logical File
+ showLang English KGV  = "ELF" -- External Logical File
+ showLang English IF   = "EI"  -- External Input
+ showLang English UF   = "EO"  -- External Output
+ showLang English OF   = "EQ"  -- External inQuiry
+ 
+instance ShowLang FPA where
+ showLang lang x = showLang lang (fpType x)++" "++showLang lang (complexity x)
+
+-- | Valuing of function points according to par. 3.9 (UK) or par. 2.9 (NL) 
+fPoints' :: FPA -> Int
+fPoints' (FPA ILGV Eenvoudig) = 7
+fPoints' (FPA ILGV Gemiddeld) = 10
+fPoints' (FPA ILGV Moeilijk ) = 15
+fPoints' (FPA KGV  Eenvoudig) = 5
+fPoints' (FPA KGV  Gemiddeld) = 7
+fPoints' (FPA KGV  Moeilijk ) = 10
+fPoints' (FPA IF   Eenvoudig) = 3
+fPoints' (FPA IF   Gemiddeld) = 4
+fPoints' (FPA IF   Moeilijk ) = 6
+fPoints' (FPA UF   Eenvoudig) = 4
+fPoints' (FPA UF   Gemiddeld) = 5
+fPoints' (FPA UF   Moeilijk ) = 7
+fPoints' (FPA OF   Eenvoudig) = 3
+fPoints' (FPA OF   Gemiddeld) = 4
+fPoints' (FPA OF   Moeilijk ) = 6
+   
+
+ src/lib/DatabaseDesign/Ampersand/Fspec/Fspec.hs view
@@ -0,0 +1,431 @@+{-# OPTIONS_GHC -Wall #-}
+{- | The intentions behind Fspc (SJ 30 dec 2008):
+Generation of functional specifications is the core functionality of Ampersand.
+All items in a specification are generated into the following data structure, Fspc.
+It is built by compiling an Ampersand script and translating that to Fspc.
+In the future, other ways of 'filling' Fspc are foreseen.
+All generators (such as the code generator, the proof generator, the atlas generator, etc.)
+are merely different ways to show Fspc.
+-}
+module DatabaseDesign.Ampersand.Fspec.Fspec 
+          ( Fspc(..), Fswitchboard(..),  Clauses(..), Quad(..)
+          , FSid(..), FProcess(..)
+          , InsDel(..)
+          , ECArule(..)
+          , Event(..)
+          , PAclause(..)
+          , Activity(..)
+          , PlugSQL(..)
+          , lookupCpt
+          , metaValues
+          , SqlField(..)
+          , FPA(..)
+          , FPtype(..)
+          , FPcompl(..)
+          , PlugInfo(..)
+          , SqlType(..)
+          , SqlFieldUsage(..)
+          , getGeneralizations, getSpecializations
+          , RuleClause(..),DnfClause(..), dnf2expr, events
+          )
+where
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+import DatabaseDesign.Ampersand.Classes
+import DatabaseDesign.Ampersand.Basics
+import Data.List(nub)
+import DatabaseDesign.Ampersand.ADL1.Pair
+import DatabaseDesign.Ampersand.ADL1.Expression (notCpl)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Fspec.Fspec"
+
+data Fspc = Fspc { fsName ::       String                   -- ^ The name of the specification, taken from the Ampersand script
+                 , fspos ::        [Origin]                 -- ^ The origin of the Fspc. An Fspc can be a merge of a file including other files c.q. a list of Origin.
+                 , themes ::       [String]                 -- ^ The names of patterns/processes to be printed in the functional specification. (for making partial documentation)
+                 , fsLang ::       Lang                     -- ^ The default language for this specification, if specified at all.
+                 , vprocesses ::   [FProcess]               -- ^ All processes defined in the Ampersand script
+                 , vplugInfos ::   [PlugInfo]               -- ^ All plugs defined in the Ampersand script
+                 , plugInfos ::    [PlugInfo]               -- ^ All plugs (defined and derived)
+                 , interfaceS ::   [Interface]              -- ^ All interfaces defined in the Ampersand script
+                 , interfaceG ::   [Interface]              -- ^ All interfaces derived from the basic ontology
+                 , fSwitchboard :: Fswitchboard             -- ^ The code to be executed to maintain the truth of invariants
+                 , fActivities ::  [Activity]               -- ^ generated: One Activity for every ObjectDef in interfaceG and interfaceS 
+                 , fRoleRels ::    [(String,Declaration)]   -- ^ the relation saying which roles may change the population of which relation.
+                 , fRoleRuls ::    [(String,Rule)]          -- ^ the relation saying which roles may change the population of which relation.
+                 , vrules ::       [Rule]                   -- ^ All user defined rules that apply in the entire Fspc
+                 , grules ::       [Rule]                   -- ^ All rules that are generated: multiplicity rules and identity rules
+                 , invars ::       [Rule]                   -- ^ All invariant rules
+                 , allRules::      [Rule]                   -- ^ All rules, both generated (from multiplicity and keys) as well as user defined ones.
+                 , allUsedDecls :: [Declaration]            -- ^ All used declarations in the fspec
+                 , allDecls ::     [Declaration]            -- ^ All declarations in the fspec
+                 , allConcepts ::  [A_Concept]              -- ^ All concepts in the fspec
+                 , kernels ::      [[A_Concept]]            -- ^ All concepts, grouped by their classifications
+                 , vIndices ::     [IdentityDef]            -- ^ All keys that apply in the entire Fspc
+                 , vviews ::       [ViewDef]                -- ^ All views that apply in the entire Fspc
+                 , vgens ::        [A_Gen]                  -- ^ All gens that apply in the entire Fspc
+                 , vconjs ::       [RuleClause]             -- ^ All conjuncts generated (by ADL2Fspec)
+                 , vquads ::       [Quad]                   -- ^ All quads generated (by ADL2Fspec)
+                 , vEcas ::        [ECArule]                -- ^ All ECA rules generated (by ADL2Fspec)
+                 , vrels ::        [Declaration]            -- ^ All user defined and generated declarations plus all defined and computed totals.
+                                                            --   The generated declarations are all generalizations and
+                                                            --   one declaration for each signal.
+                 , fsisa ::        [(A_Concept, A_Concept)] -- ^ generated: The data structure containing the generalization structure of concepts
+                 , vpatterns ::    [Pattern]                -- ^ All patterns taken from the Ampersand script
+                 , vConceptDefs :: [ConceptDef]             -- ^ All conceptDefs defined in the Ampersand script including those of concepts not in concs fSpec
+                 , 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 declarations from the entire context      
+                 , initialPops ::    [Population]           -- all user defined populations of relations and concepts
+                 , allViolations ::  [(Rule,[Paire])]       -- all rules with violations.
+                 }
+metaValues :: String -> Fspc -> [String]
+metaValues key fSpec = [mtVal m | m <-metas fSpec, mtName m == key]
+  
+
+instance ConceptStructure Fspc where
+  concs     fSpec = concs (vrels fSpec)                     -- The set of all concepts used in this Fspc
+  expressionsIn fSpec = foldr (uni) []
+                        [ (expressionsIn.interfaceS) fSpec
+                        , (expressionsIn.vrules) fSpec
+                        ]
+  mp1Exprs  _ = fatal 77 "do not use mp1Exprs from an Fspc"
+  
+instance Language Fspc where
+  objectdef    fSpec = Obj { objnm   = name fSpec
+                           , objpos  = Origin "generated object by objectdef (Language Fspc)"
+                           , objctx  = EDcI ONE
+                           , objmsub = Just . Box ONE $ map ifcObj (interfaceS fSpec ++ interfaceG fSpec)
+                           , objstrs = []
+                           }
+  conceptDefs fSpec = nub (concatMap cptdf (concs fSpec)) --use vConceptDefs to get CDs of concepts not in concs too
+   --REMARK: in the fspec we do not distinguish between the disjoint relation declarations and rule declarations (yet?). 
+  declarations = vrels
+  udefrules    = vrules -- only user defined rules
+  invariants   = invars
+  identities      = vIndices
+  viewDefs     = vviews
+  gens         = vgens
+  patterns     = vpatterns
+
+data FProcess
+  = FProc { fpProc :: Process
+          , fpActivities :: [Activity]
+          }  
+instance Identified FProcess where
+  name = name . fpProc 
+
+instance Language FProcess where
+  objectdef    = objectdef.fpProc
+  conceptDefs  = conceptDefs.fpProc
+  declarations = declarations.fpProc
+  udefrules    = udefrules.fpProc
+  invariants   = invariants.fpProc
+  identities      = identities.fpProc
+  viewDefs     = viewDefs.fpProc
+  gens         = gens.fpProc
+  patterns     = patterns.fpProc
+
+-- | A list of ECA rules, which is used for automated functionality.
+data Fswitchboard
+  = Fswtch { fsbEvIn :: [Event]
+           , fsbEvOut :: [Event]
+           , fsbConjs :: [(Rule, Expression)]
+           , fsbECAs :: [ECArule]
+           }
+
+    
+--type Fields = [Field]
+--data Field  = Att { fld_name :: String        -- The name of this field
+--                  , fld_sub :: Fields        -- all sub-fields
+--                  , fld_expr :: Expression    -- The expression by which this field is attached to the interface
+--                  , fld_rel :: Relation      -- The relation to which the database table is attached.
+--                  , fld_editable :: Bool          -- can this field be changed by the user of this interface?
+--                  , fld_list :: Bool          -- can there be multiple values in this field?
+--                  , fld_must :: Bool          -- is this field obligatory?
+--                  , fld_new :: Bool          -- can new elements be filled in? (if no, only existing elements can be selected)
+--                  , fld_sLevel :: Int           -- The (recursive) depth of the current servlet wrt the entire interface. This is used for documentation.
+--                  , fld_insAble :: Bool          -- can the user insert in this field?
+--                  , fld_onIns :: ECArule       -- the PAclause to be executed after an insert on this field
+--                  , fld_delAble :: Bool          -- can the user delete this field?
+--                  , fld_onDel :: ECArule       -- the PAclause to be executed after a delete on this field
+--                  } 
+   
+
+{- from http://www.w3.org/TR/wsdl20/#InterfaceOperation
+ - "The properties of the Interface Operation component are as follows:
+ - ...
+ - * {interface message references} OPTIONAL. A set of Interface Message Reference components for the ordinary messages the operation accepts or sends.
+ - ..."
+-}
+   
+data FSid = FS_id String     -- Identifiers in the Functional Specification Language contain strings that do not contain any spaces.
+        --  | NoName           -- some identified objects have no name...
+instance Identified Fspc where
+  name = fsName
+
+
+instance Identified FSid where
+  name (FS_id nm) = nm
+
+
+data Activity = Act { actRule ::   Rule
+                    , actTrig ::   [Declaration]
+                    , actAffect :: [Declaration]
+                    , actQuads ::  [Quad]
+                    , actEcas ::   [ECArule]
+                    , actPurp ::   [Purpose]
+                    }
+instance Identified Activity where
+  name act = name (actRule act)
+-- | A Quad is used in the "switchboard" of rules. It represents a "proto-rule" with the following meaning:
+--   whenever qRel is affected (i.e. tuples in qRel are inserted or deleted), qRule may have to be restored using functionality from qClauses.
+--   The rule is taken along for traceability.
+       
+instance ConceptStructure Activity where
+ concs         act = concs (actRule act) `uni` concs (actAffect act)
+ expressionsIn act = expressionsIn (actRule act)
+
+data Quad
+     = Quad
+          { qDcl :: Declaration        -- The relation that, when affected, triggers a restore action.
+          , qClauses :: Clauses         -- The clauses
+          }
+     | LoopSearchQuad  -- HJO: 2013-11-23: Temporary constructor, because of suspection of quads in generation of loops: just testing with it.
+          { qDcl  :: Declaration
+          , qRule :: Rule
+          , debugStr :: String 
+          } deriving Eq
+ 
+instance Eq Activity where
+  a == a'  = actRule a == actRule a'
+
+data InsDel   = Ins | Del
+                 deriving (Show,Eq)
+data ECArule= ECA { ecaTriggr :: Event     -- The event on which this rule is activated
+                  , ecaDelta :: Declaration  -- The delta to be inserted or deleted from this rule. It actually serves very much like a formal parameter.
+                  , ecaAction :: PAclause  -- The action to be taken when triggered.
+                  , ecaNum :: Int       -- A unique number that identifies the ECArule within its scope.
+                  }
+instance Eq (ECArule) where
+   e==e' = ecaNum e==ecaNum e'
+   
+data Event = On { eSrt :: InsDel
+                , eDcl :: Declaration
+                } deriving (Show)
+instance Eq Event where
+ q == q' = fatal 260 "TODO Han: Eq moet worden teruggezet voor Event"
+
+data PAclause
+              = CHC { paCls :: [PAclause]
+                    , paMotiv :: [(Expression,[Rule] )]   -- tells which conjunct from whichule is being maintained
+                    }
+              | ALL { paCls :: [PAclause]
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+              | Do  { paSrt :: InsDel                     -- do Insert or Delete
+                    , paTo :: Declaration                    -- into toExpr    or from toExpr
+                    , paDelta :: Expression               -- delta
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+              | Sel { paCpt :: A_Concept                  -- pick an existing instance of type c
+                    , paExp :: Expression                 -- the expression to pick from
+                    , paCl :: String->PAclause            -- the completion of the clause
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+              | New { paCpt :: A_Concept                  -- make a new instance of type c
+                    , paCl :: String->PAclause            -- to be done after creating the concept
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+              | Rmv { paCpt :: A_Concept                  -- Remove an instance of type c
+                    , paCl :: String->PAclause            -- to be done afteremoving the concept
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+              | Nop { paMotiv :: [(Expression,[Rule] )]   -- tells which conjunct from whichule is being maintained
+                    }
+              | Blk { paMotiv :: [(Expression,[Rule] )]   -- tells which expression from whichule has caused the blockage
+                    }
+              | Let { paExpr :: PAclause                  -- the expression that represents a condition to be tested.
+                    , paBody :: PAclause -> PAclause
+                    , paMotiv :: [(Expression,[Rule] )]
+                    }
+              | Ref { paVar :: String
+                    }
+
+events :: PAclause -> [(InsDel,Declaration)]
+events paClause = nub (evs paClause)
+ where evs clause
+        = case clause of
+           CHC{} -> (concat.map evs) (paCls clause)
+           ALL{} -> (concat.map evs) (paCls clause)
+           Do{}  -> [(paSrt paClause, paTo clause)]
+           Sel{} -> evs (paCl clause "")
+           New{} -> evs (paCl clause "")
+           Rmv{} -> evs (paCl clause "")
+           Nop{} -> []
+           Blk{} -> []
+           Let{} -> fatal 305 "events for let undetermined"
+           Ref{} -> fatal 306 "events for Ref undetermined"
+
+   -- The data structure Clauses is meant for calculation purposes.
+   -- It must always satisfy for every i<length (cl_rule cl): cl_rule cl is equivalent to EIsc [EUni disj | (conj, dnfClauses)<-cl_conjNF cl, disj<-[conj!!i]]
+   -- Every rule is transformed to this form, as a step to derive eca-rules
+instance Eq PAclause where
+   CHC ds _ == CHC ds' _ = ds==ds'
+   ALL ds _ == ALL ds' _ = ds==ds'
+   p@Do{}   ==   p'@Do{} = paSrt p==paSrt p' && paTo p==paTo p' && paDelta p==paDelta p'
+   Nop _    ==     Nop _ = True
+   p@New{}  ==  p'@New{} = paCpt p==paCpt p'
+   p@Rmv{}  ==  p'@Rmv{} = paCpt p==paCpt p'
+   _ == _ = False
+
+
+data DnfClause = Dnf [Expression] [Expression] deriving (Show, Eq) -- Show is for debugging purposes only.
+
+--
+dnf2expr :: DnfClause -> Expression
+dnf2expr (Dnf antcs conss)
+ = case (antcs, conss) of
+    ([],[]) -> fatal 327 "empty dnf clause"
+    ([],_ ) -> foldr1 (.\/.) conss
+    (_ ,[]) -> notCpl (foldr1 (./\.) antcs)
+    (_ ,_ ) -> notCpl (foldr1 (./\.) antcs) .\/. (foldr1 (.\/.) conss)
+
+data Clauses  = Clauses
+                  { cl_conjNF :: [RuleClause]   -- The list of pairs (conj, dnfClauses) in which conj is a conjunct of the rule
+                                                    -- and dnfClauses contains all derived expressions to be used for eca-rule construction.
+                  , cl_rule :: Rule -- The rule that is restored by this clause (for traceability purposes)
+                  }
+data RuleClause = RC { rc_int        :: Int  -- the index number of the expression for the rule. (must be unique for the rule)
+                     , rc_rulename   :: String -- the name of the rule
+                     , rc_conjunct   :: Expression
+                     , rc_dnfClauses :: [DnfClause]
+                     }
+instance Eq Clauses where
+  cl==cl' = cl_rule cl==cl_rule cl'
+    
+{-
+   showClauses :: Fspc -> Clauses -> String
+   showClauses _ cl
+    = "\nRule: "++showADL (cl_rule cl) ++concat
+       [if null dnfClauses then "\nNo clauses" else
+        "\nConjunct: "++showADL conj++
+        concat ["\n   Clause: "++showADL clause | clause<-dnfClauses]
+       | (conj, dnfClauses)<-cl_conjNF cl]
+-}
+
+data FPA = FPA { fpType :: FPtype
+               , complexity :: FPcompl
+               } deriving (Show)
+
+-- | These types are defined bij Nesma. See http://www.nesma.nl/sectie/fpa/hoefpa.asp
+data FPtype 
+ = ILGV -- ^ bevat permanente, voor de gebruiker relevante gegevens. De gegevens worden door het systeem gebruikt en onderhouden. Onder "onderhouden" verstaat FPA het toevoegen, wijzigen of verwijderen van gegevens.
+ | KGV  -- ^ bevat permanente, voor de gebruiker relevante gegevens. Deze gegevens worden door het systeem gebruikt, maar worden door een ander systeem onderhouden (voor dat andere systeem is het dus een ILGV).
+ | IF   -- ^ verwerkt gegevens in een ILGV van het systeem. (dus create, update en delete functies)
+ | UF   -- ^ presenteert gegevens uit het systeem. Voorbeelden: het afdrukken van alle debiteuren; het aanmaken van facturen; het aanmaken van een diskette met betalingsopdrachten; het medium is hierbij niet van belang: papier, scherm, magneetband, datacom, enzovoorts.
+ | OF   -- ^ is een speciaal (eenvoudig) soort uitvoerfunctie. Een opvraagfunctie presenteert gegevens uit het systeem op basis van een uniek identificerend zoekgegeven, waarbij geen aanvullende bewerkingen (zoals berekeningen of het bijwerken van een gegevensverzameling) plaats hebben. Voorbeeld: Het tonen van de gegevens van de klant met klantnummer 123456789.
+          deriving (Eq, Show)
+
+data FPcompl = Eenvoudig | Gemiddeld | Moeilijk deriving (Eq, Show)
+
+
+
+
+data PlugInfo = InternalPlug PlugSQL 
+              | ExternalPlug ObjectDef
+                deriving (Show, Eq)
+instance Identified PlugInfo where
+  name (InternalPlug psql) = name psql
+  name (ExternalPlug obj)  = name obj
+
+data PlugSQL
+   -- | stores a related collection of relations: a kernel of concepts and attribute relations of this kernel
+   --   i.e. a list of SqlField given some A -> [target r | r::A*B,isUni r,isTot r, isInj r] 
+   --                                        ++ [target r | r::A*B,isUni r, not(isTot r), not(isSur r)]
+   --     kernel = A closure of concepts A,B for which there exists a r::A->B[INJ] 
+   --              (r=fldexpr of kernel field holding instances of B, in practice r is I or a makeRelation(flipped declaration))
+   --      attribute relations = All concepts B, A in kernel for which there exists a r::A*B[UNI] and r not TOT and SUR
+   --              (r=fldexpr of attMor field, in practice r is a makeRelation(declaration))
+ = TblSQL  { sqlname :: String
+           , fields :: [SqlField]                          -- ^ the first field is the concept table of the most general concept (e.g. Person)
+                                                           --   then follow concept tables of specializations. Together with the first field this is called the "kernel"
+                                                           --   the remaining fields represent attributes.
+           , cLkpTbl :: [(A_Concept,SqlField)]             -- ^ lookup table that links all kernel concepts to fields in the plug
+                                                           -- cLkpTbl is een lijst concepten die in deze plug opgeslagen zitten, en hoe je ze eruit kunt halen
+           , mLkpTbl :: [(Expression,SqlField,SqlField)]   -- ^ lookup table that links concepts to column names in the plug (kernel+attRels)
+                                                           -- mLkpTbl is een lijst met relaties die in deze plug opgeslagen zitten, en hoe je ze eruit kunt halen
+           }
+   -- | stores one relation r in two ordered columns
+   --   i.e. a tuple of SqlField -> (source r,target r) with (fldexpr=I/\r;r~, fldexpr=r) 
+   --   (note: if r TOT then (I/\r;r~ = I). Thus, the concept (source r) is stored in this plug too)
+   --   with tblcontents = [[x,y] |(x,y)<-contents r]. 
+   --   Typical for BinSQL is that it has exactly two columns that are not unique and may not contain NULL values
+ | BinSQL  { sqlname :: String
+           , columns :: (SqlField,SqlField)
+           , cLkpTbl :: [(A_Concept,SqlField)] --given that mLkp cannot be (UNI or INJ) (because then r would be in a TblSQL plug)
+                                                --if mLkp is TOT, then the concept (source mLkp) is stored in this plug
+                                                --if mLkp is SUR, then the concept (target mLkp) is stored in this plug
+           , mLkp :: Expression -- the relation links concepts implemented by this plug
+           }
+ -- |stores one concept c in one column
+ --  i.e. a SqlField -> c
+ --  with tblcontents = [[x] |(x,_)<-contents c].
+ --  Typical for ScalarSQL is that it has exactly one column that is unique and may not contain NULL values i.e. fldexpr=I[c]
+ | ScalarSQL
+           { sqlname :: String
+           , sqlColumn :: SqlField
+           , cLkp :: A_Concept -- the concept implemented by this plug
+           }
+   deriving (Show) 
+instance Identified PlugSQL where
+  name = sqlname
+instance Eq PlugSQL where
+  x==y = name x==name y
+instance Ord PlugSQL where
+  compare x y = compare (name x) (name y)
+
+-- | This returns all column/table pairs that serve as a concept table for cpt. When adding/removing atoms, all of these
+-- columns need to be updated 
+lookupCpt :: Fspc -> A_Concept -> [(PlugSQL,SqlField)]
+lookupCpt fSpec cpt = [(plug,fld) |InternalPlug plug@TblSQL{}<-plugInfos fSpec, (c,fld)<-cLkpTbl plug,c==cpt]++
+                 [(plug,fld) |InternalPlug plug@BinSQL{}<-plugInfos fSpec, (c,fld)<-cLkpTbl plug,c==cpt]++
+                 [(plug,sqlColumn plug) |InternalPlug plug@ScalarSQL{}<-plugInfos fSpec, cLkp plug==cpt]
+
+data SqlFieldUsage = PrimKey A_Concept     -- The field is the primary key of the table
+                   | ForeignKey A_Concept  -- The field is a reference (containing the primary key value of) a TblSQL
+                   | PlainAttr             -- None of the above
+                   | NonMainKey            -- Key value of an Specialization of the Primary key. (field could be null)
+                   | UserDefinedUsage
+                   | FillInLater          -- Must be filled in later....
+                   deriving (Eq, Show)
+
+data SqlField = Fld { fldname :: String
+                    , fldexpr :: Expression     -- ^ De target van de expressie geeft de waarden weer in de SQL-tabel-kolom.
+                    , fldtype :: SqlType
+                    , flduse ::  SqlFieldUsage
+                    , fldnull :: Bool           -- ^ can there be empty field-values? (intended for data dictionary of DB-implementation)
+                    , flduniq :: Bool           -- ^ are all field-values unique? (intended for data dictionary of DB-implementation)
+                    } deriving (Eq, Show)
+
+instance Ord SqlField where
+  compare x y = compare (fldname x) (fldname y)
+                    
+                    
+data SqlType = SQLChar    Int
+             | SQLBlob              -- cannot compare, but can show (as a file)
+             | SQLPass              -- password, encrypted: cannot show, but can compare
+             | SQLSingle  
+             | SQLDouble  
+             | SQLText              -- cannot compare, but can show (as a text)
+             | SQLuInt    Int
+             | SQLsInt    Int
+             | SQLId                -- autoincrement integer
+             | SQLVarchar Int
+             | SQLBool              -- exists y/n
+             deriving (Eq,Show)
+
+getGeneralizations :: Fspc -> A_Concept -> [A_Concept]
+getGeneralizations fSpec = largerConcepts (gens fSpec)
+
+getSpecializations :: Fspc -> A_Concept -> [A_Concept]
+getSpecializations fSpec = smallerConcepts (gens fSpec)
+
+ src/lib/DatabaseDesign/Ampersand/Fspec/GenerateUML.hs view
@@ -0,0 +1,280 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Fspec.GenerateUML (generateUML) where
+
+import DatabaseDesign.Ampersand.Basics
+import DatabaseDesign.Ampersand.Misc
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree (explMarkup,aMarkup2String,Rule,Declaration,Purpose(..))
+import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram
+import DatabaseDesign.Ampersand.Fspec
+import Data.Map (Map)
+import Data.List
+import qualified Data.Map as Map
+import Control.Monad.State.Lazy  (State, gets, evalState, modify)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Fspec.GenerateUML"
+
+-- TODO: escape
+-- TODO: names of model, package, assoc (empty?), etc.
+
+generateUML :: Fspc -> Options -> String
+generateUML fSpec flags = showUML (fSpec2UML fSpec flags)
+
+showUML :: UML -> String
+showUML uml = unlines $ evalState uml $ UMLState 0 Map.empty [] []
+
+fSpec2UML :: Fspc -> Options -> UML
+fSpec2UML fSpec flags = 
+ do { packageId0 <- mkUnlabeledId "TopPackage"
+    ; packageId1 <- mkUnlabeledId "PackageClasses" 
+    ; packageId2 <- mkUnlabeledId "PackageReqs"
+    ; diagramId <- mkUnlabeledId "Diagram"
+    
+    ; _ <- mapM (mkLabeledId "Datatype") datatypeNames
+    ; _ <- mapM (mkLabeledId "Class") classNames
+
+    ; datatypesUML <- mapM genUMLDatatype datatypeNames
+    ; classesUML <- mapM genUMLClass (classes classDiag)
+    ; assocsUML <- mapM genUMLAssociation (assocs classDiag)
+    ; requirementsUML <- mapM genUMLRequirement (requirements flags fSpec)
+    ; diagramElements <- genDiagramElements 
+    ; customProfileElements <- genCustomProfileElements
+    ; customReqElements <- genCustomReqElements flags packageId2
+    ; return $ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
+               , "<!-- Generated by "++ampersandVersionStr++" -->"
+               , "<xmi:XMI xmi:version=\"2.1\" xmlns:uml=\"http://schema.omg.org/spec/UML/2.1\" xmlns:xmi=\"http://schema.omg.org/spec/XMI/2.1\" xmlns:thecustomprofile=\"http://www.sparxsystems.com/profiles/thecustomprofile/1.0\">"
+               -- WHY is the exporter not something like `Ampersand` (in the string below)?
+               -- BECAUSE then for some reason the importer doesn't show the properties of the requirements.
+               , " <xmi:Documentation exporter=\"Enterprise Architect\" exporterVersion=\"6.5\"/>"
+               , " <uml:Model xmi:type=\"uml:Model\" name=\""++contextName++"\" visibility=\"public\">"
+               , "  <packagedElement xmi:type=\"uml:Package\" xmi:id="++show packageId0++" name="++show contextName++" visibility=\"public\">" ] ++
+               [ "   <packagedElement xmi:type=\"uml:Package\" xmi:id="++show packageId1++" name="++show ("classesOf_"++contextName)++" visibility=\"public\">" ] ++
+               concat datatypesUML ++
+               concat classesUML ++ 
+               concat assocsUML ++
+               [ "   </packagedElement>" ] ++
+               [ "   <packagedElement xmi:type=\"uml:Package\" xmi:id="++show packageId2++" name="++show ("RequirementsOf_"++contextName)++" visibility=\"public\">" ] ++
+               concat requirementsUML ++
+               [ "   </packagedElement>" ] ++
+               [ "  </packagedElement>" ] ++
+               customProfileElements ++
+               [ " </uml:Model>"
+               , " <xmi:Extension extender=\"Enterprise Architect\" extenderID=\"6.5\">"
+               , "  <elements>"] ++
+               [ "    <element xmi:idref="++show packageId0++" xmi:type=\"uml:Package\" name="++show contextName++" scope=\"public\">"]++
+               [ "    </element>"]++
+               [ "    <element xmi:idref="++show packageId1++" xmi:type=\"uml:Package\" name="++show ("classesOf_"++contextName)++" scope=\"public\">"]++
+               [ "     <model package2="++show packageId1++" package="++show packageId0++" tpos=\"0\" ea_eleType=\"package\"/>"]++
+               [ "    </element>"]++
+               [ "    <element xmi:idref="++show packageId2++" xmi:type=\"uml:Package\" name="++show ("RequirementsOf_"++contextName)++" scope=\"public\">"]++
+               [ "     <model package2="++show packageId2++" package="++show packageId0++" tpos=\"0\" ea_eleType=\"package\"/>"]++
+               [ "    </element>"]++
+               customReqElements ++
+               [ "  </elements>"
+               , "  <diagrams>"
+               , "   <diagram xmi:id=\""++diagramId++"\">"
+               , "    <model package=\""++packageId1++"\" owner=\""++packageId1++"\"/>"
+               , "    <properties name=\"Data Model\" type=\"Logical\"/>"
+               , "    <elements>" ] ++
+               diagramElements ++
+               [ "    </elements>"
+               , "   </diagram>"
+               , "  </diagrams>"
+               , " </xmi:Extension>"
+               , "</xmi:XMI>" ]
+    }
+ where classDiag = cdAnalysis fSpec flags
+       contextName = cdName classDiag
+       allConcs = ooCpts classDiag
+       classNames    = map name (classes classDiag)
+       datatypeNames = map name allConcs >- classNames
+
+genUMLRequirement :: Req -> UML
+genUMLRequirement req =
+ do { reqLId <- mkUnlabeledId "Req"
+    ; addReqToState (reqLId, req)
+    ; return $ [ "    <packagedElement xmi:type=\"uml:Class\" xmi:id=\""++reqLId++"\" name=\""++reqId req++"\" visibility=\"public\"/> " ] 
+    }
+
+genUMLDatatype :: String -> UML
+genUMLDatatype nm =
+ do { datatypeId <- refLabeledId nm
+    ; addToDiagram datatypeId
+    ; return [ "    <packagedElement xmi:type=\"uml:DataType\" xmi:id=\""++datatypeId++"\" name=\""++nm++"\" visibility=\"public\"/> " ]
+    }
+
+genUMLClass :: Class -> UML
+genUMLClass cl =
+ do { classId <- refLabeledId (clName cl)
+    ; addToDiagram classId
+    ; attributesUML <- mapM genUMAttribute (clAtts cl)
+    ; return $ [ "    <packagedElement xmi:type=\"uml:Class\" xmi:id=\""++classId++"\" name=\""++clName cl++"\" visibility=\"public\">"] ++
+               concat attributesUML ++
+               [ "    </packagedElement>"]
+    }
+
+genUMAttribute :: CdAttribute -> UML
+genUMAttribute  (OOAttr nm attrType optional) =
+ do { attrId <- mkUnlabeledId "Attr"
+    ; lIntId <- mkUnlabeledId "Int"
+    ; uIntId <- mkUnlabeledId "Int"
+    ; classId <- refLabeledId attrType
+    ; return [ "       <ownedAttribute xmi:type=\"uml:Property\" xmi:id=\""++attrId++"\" name=\""++nm++"\" visibility=\"public\" isStatic=\"false\""++
+                                    " isReadOnly=\"false\" isDerived=\"false\" isOrdered=\"false\" isUnique=\"true\" isDerivedUnion=\"false\">"
+             , "        <type xmi:idref=\""++classId++"\"/>"
+             , "        <lowerValue xmi:type=\"uml:LiteralInteger\" xmi:id=\""++lIntId++"\" value=\""++(if optional then "0" else "1")++"\"/>"
+             , "        <upperValue xmi:type=\"uml:LiteralInteger\" xmi:id=\""++uIntId++"\" value=\"1\"/>"
+             , "       </ownedAttribute>"]
+    }
+
+genUMLAssociation :: Association -> UML
+genUMLAssociation ass = 
+ do { assocId <- mkUnlabeledId "Assoc"
+    ; lMemberAndOwnedEnd <- genMemberAndOwnedEnd (asslhm ass) assocId (assSrc ass)
+    ; rMemberAndOwnedEnd <- genMemberAndOwnedEnd (assrhm ass) assocId (assTrg ass)
+        
+    ; return $
+        [ "    <packagedElement xmi:type=\"uml:Association\" xmi:id=\""++assocId++"\" name=\""++assrhr ass++"\" visibility=\"public\">"
+        ] ++
+        lMemberAndOwnedEnd ++
+        rMemberAndOwnedEnd ++
+        [ "    </packagedElement>"
+        ]
+    }
+ where genMemberAndOwnedEnd (Mult minVal maxVal) assocId type' =
+        do { endId <- mkUnlabeledId "MemberEnd"
+           ; typeId <- refLabeledId (case type' of
+                                       Left c -> name c
+                                       Right s -> s
+                                    )
+           ; lIntId <- mkUnlabeledId "Int"
+           ; uIntId <- mkUnlabeledId "Int"
+           ; return 
+               [ "     <memberEnd xmi:idref=\""++endId++"\"/>"
+               , "     <ownedEnd xmi:type=\"uml:Property\" xmi:id=\""++endId++"\" visibility=\"public\" association=\""++assocId++"\" isStatic=\"false\""++
+                              " isReadOnly=\"false\" isDerived=\"false\" isOrdered=\"false\" isUnique=\"true\" isDerivedUnion=\"false\" aggregation=\"none\">"
+               , "      <type xmi:idref=\""++typeId++"\"/>"
+               , "      <lowerValue xmi:type=\"uml:LiteralInteger\" xmi:id=\""++lIntId++"\" value=\""++(if minVal == MinZero then "0" else "1")++"\"/>"
+               , case maxVal of
+                   MaxOne  -> "      <upperValue xmi:type=\"uml:LiteralInteger\" xmi:id=\""++uIntId++"\" value=\"1\"/>"
+                   MaxMany -> "      <upperValue xmi:type=\"uml:LiteralUnlimitedNatural\" xmi:id=\""++uIntId++"\" value=\"-1\"/>"
+               , "     </ownedEnd>"
+               ]
+           }
+           
+genDiagramElements :: UML
+genDiagramElements =
+ do { elementIds <- gets diagramEltIds
+    ; return [ "      <element subject=\""++elementId++"\"/>" | elementId <- elementIds ]
+    }
+
+genCustomProfileElements :: UML
+genCustomProfileElements =
+ do { reqVals <- gets reqValues
+    ; return  [reqUML req | req <- reverse reqVals]
+    }
+  where
+    reqUML :: ReqValue2 -> String
+    reqUML (xmiId, req) = intercalate "\n"
+     ( ["   <thecustomprofile:Functional base_Requirement="++show xmiId++"/>"]++
+       [tagUML xmiId count puprtxt reftxt | (count, (puprtxt, reftxt)) <- zip [0::Int ..] [(aMarkup2String (explMarkup p), explRefId p) | p <- reqPurposes req]]
+     )
+    tagUML xmiId nr value reftxt = intercalate "\n"
+      [ "     <thecustomprofile:"++keyMeaning++" base_Requirement="++show xmiId++" "++keyMeaning++"="++show value++"/>"
+      , "     <thecustomprofile:"++keyRef    ++" base_Requirement="++show xmiId++" "++keyRef++"="++show reftxt++"/>"
+      ]
+        where keyMeaning = "Meaning"++show nr
+              keyRef     = "Reference"++show nr
+              
+genCustomReqElements :: Options -> String -> UML
+genCustomReqElements flags parentPackageId =
+ do { reqVals <- gets reqValues
+    ; return [reqUML req | req <- reverse reqVals]
+    }
+  where
+    reqUML :: ReqValue2 -> String
+    reqUML (xmiId, req) = intercalate "\n"
+     ([ "    <element xmi:idref="++show xmiId++" xmi:type=\"uml:Requirement\" name="++show (reqId req)++" scope=\"public\""++">"
+      , "      <model package="++show parentPackageId++" ea_eleType=\"element\"/>"
+      , "      <properties documentation="++show (maybe "" aMarkup2String (meaning (language flags) req))++" isSpecification=\"false\" sType=\"Requirement\" nType=\"0\" scope=\"public\" stereotype=\"Functional\"/>"
+      , "      <tags>"]++
+      [ "         <tag name=\"Purpose"++nr++"\" value="++show p++" modelElement="++show xmiId++"/>" | (nr ,p) <- zip ("" : map show [1::Int ..]) ([aMarkup2String (explMarkup p) | p <- reqPurposes req])  ]++
+      [ "      </tags>"
+      , "    </element>"
+      ])
+
+-- Requirements
+
+data Req = Req { reqId :: String
+            --   , reqRef :: String
+               , reqOrig :: Either Rule Declaration
+               , reqPurposes :: [Purpose]
+               }
+
+instance Meaning Req where
+  meaning l r = case reqOrig r of
+                  Right rul -> meaning l rul
+                  Left  dcl -> meaning l dcl
+
+requirements :: Options -> Fspc -> [Req]
+requirements flags fSpec
+   = [decl2req d | d <- vrels  fSpec]
+   ++[rule2req r | r <- vrules fSpec]
+  where
+    decl2req d = Req { reqId = name d
+                     , reqOrig = Right d
+                     , reqPurposes = purposesDefinedIn fSpec (language flags) d
+                     }
+    rule2req r = Req { reqId = name r
+                     , reqOrig = Left r
+                     , reqPurposes = purposesDefinedIn fSpec (language flags) r
+                     }
+                     
+
+
+-- State and Monad
+
+data UMLState = UMLState { idCounter :: Int
+                         , labelIdMap :: Map String String
+                         , diagramEltIds :: [String]
+                         , reqValues :: [ReqValue2]
+                         }
+                         
+type StateUML a = State UMLState a
+                           
+
+type UML = StateUML [String]
+
+type ReqValue2 = ( String -- the xmi-id
+                , Req
+                )
+
+addToDiagram :: String -> StateUML ()
+addToDiagram elementId =
+  modify $ \state' -> state' { diagramEltIds = elementId : diagramEltIds state'} 
+
+addReqToState :: ReqValue2 -> StateUML ()
+addReqToState reqVal =
+  modify $ \state' -> state' { reqValues = reqVal : reqValues state'}
+
+mkUnlabeledId :: String -> StateUML String
+mkUnlabeledId tag =
+ do { idC <- gets idCounter 
+    ; modify $ \state' -> state' { idCounter = idCounter state' + 1}
+    ; let unlabeledId = tag++"ID_"++show idC 
+    ; return unlabeledId
+    }
+
+refLabeledId :: String -> StateUML String
+refLabeledId label =
+ do { lidMap <- gets labelIdMap
+    ; case Map.lookup label lidMap of
+          Just lid -> return lid
+          Nothing  -> fatal 147 $ "Requesting non-existent label "++label
+    }
+    
+mkLabeledId :: String -> String -> StateUML ()
+mkLabeledId tag label =
+ do { let classId = tag++"ID_"++label 
+    ; modify $ \state' -> state' { labelIdMap =  Map.insert label classId (labelIdMap state') }
+    }
+ src/lib/DatabaseDesign/Ampersand/Fspec/Graphic/ClassDiagram.hs view
@@ -0,0 +1,535 @@+{-# OPTIONS_GHC -Wall #-}
+--TODO -> clean and stuff. Among which moving classdiagram2dot to Graphviz library implementation (see Classes/Graphics.hs).
+--        I only helped it on its feet and I have put in the fSpec, now it generates stuff. I like stuff :)
+
+module DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram
+         (ClassDiag(..), Class(..), CdAttribute(..), Association(..), Aggregation(..), Generalization(..), Deleting(..), Method(..),
+          Multiplicities(..), MinValue(..), MaxValue(..),
+          clAnalysis, cdAnalysis, tdAnalysis, classdiagram2dot)
+where
+   import Data.List
+   import DatabaseDesign.Ampersand.Basics
+   import DatabaseDesign.Ampersand.Classes
+   import DatabaseDesign.Ampersand.ADL1  hiding (Association,Box)
+   import DatabaseDesign.Ampersand.Fspec.Plug
+   import DatabaseDesign.Ampersand.Misc
+   import DatabaseDesign.Ampersand.Fspec.Fspec
+   import Data.String
+   import Data.Maybe
+   import Data.GraphViz.Types.Canonical hiding (attrs)
+   import Data.GraphViz.Attributes.Complete as GVcomp
+   import Data.GraphViz.Attributes as GVatt
+   import Data.GraphViz.Attributes.HTML as Html
+   
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Fspec.Graphic.ClassDiagram"
+
+   class CdNode a where
+    nodes :: a->[String]
+
+
+   instance CdNode ClassDiag where
+    nodes cd = nub (concat (  map nodes (classes cd)
+                            ++map nodes (assocs  cd)
+                            ++map nodes (aggrs   cd)
+                            ++map nodes (geners  cd)
+                   )       )
+
+
+   instance CdNode Class where
+    nodes cl = [clName cl]
+   instance CdNode a => CdNode [a] where
+    nodes = concatMap nodes
+
+   instance CdNode CdAttribute where
+    nodes (OOAttr _ t _) = [t]
+
+   instance CdNode Method where
+    nodes _ = []
+
+   instance CdNode Association where
+    nodes a = map nm [assSrc a,assTrg a]
+      where
+       nm (Left  c  ) = name c
+       nm (Right str) = str
+
+   instance CdNode Aggregation where
+    nodes (OOAggr _ s t) = map name [s,t]
+
+   instance CdNode Generalization where
+    nodes (OOGener g ss) = map name (g:ss)
+
+   -- | This function makes the classification diagram.
+   -- It focuses on generalizations and specializations.
+   clAnalysis :: Fspc -> Options -> ClassDiag
+   clAnalysis fSpec _ = 
+       OOclassdiagram { cdName  = "classification_"++name fSpec
+                      , classes = [ OOClass { clName = name c
+                                            , clcpt  = Just c
+                                            , clAtts = attrs c
+                                            , clMths = [] 
+                                            } | c<-cpts]
+                      , assocs  = []
+                      , aggrs   = []
+                      , geners  = nub [ OOGener c (map snd gs)
+                                      | gs<-eqCl fst (fsisa fSpec)
+                                      , let c=fst (head gs), c `elem` cpts -- select only those generalisations whose specific concept is part of the themes to be printed.
+                        ]
+                      , ooCpts  = concs fSpec
+                      }
+
+    where
+       rels       = [EDcD r | r@Sgn{} <- declarations fSpec, decusr r]
+       relsAtts   = [r | e<-rels, r<-[e, flp e], isUni r]
+       cpts       = nub [ specific
+                        | specific <-map fst (fsisa fSpec)
+                         -- select only those generalisations whose specific concept is part of the themes to be printed.
+                        , specific `elem` (concs [declsUsedIn (pattsInScope fSpec) 
+                                            `uni` declsUsedIn (procsInScope fSpec)
+                                                 ])
+                        , (not.null) [ r | r<-relsAtts, source r==specific ] ||  -- c is either a concept that has attributes or
+                               null  [ r | r<-relsAtts, target r==specific ]     --      it does not occur as an attribute.
+                        ]
+
+       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))
+        
+   pattsInScope :: Fspc -> [Pattern]
+   pattsInScope fSpec = if null (themes fSpec)
+                        then patterns fSpec
+                        else [ pat | pat<-patterns fSpec, name pat `elem` themes fSpec ]
+   procsInScope :: Fspc -> [Process]
+   procsInScope fSpec = if null (themes fSpec)
+                        then map fpProc (vprocesses fSpec)
+                        else [ fpProc fprc | fprc<-vprocesses fSpec, name fprc `elem` themes fSpec ]
+
+
+
+   -- | This function, cdAnalysis, generates a conceptual data model.
+   -- It creates a class diagram in which generalizations and specializations remain distinct entity types.
+   -- This yields more classes than plugs2classdiagram does, as plugs contain their specialized concepts.
+   -- Properties and identities are not shown.
+   cdAnalysis :: Fspc -> Options -> ClassDiag
+   cdAnalysis fSpec _ = 
+     OOclassdiagram {cdName  = "logical_"++name fSpec
+                    ,classes = 
+                       [ OOClass{ clName = name root
+                                , clcpt  = Just root
+                                , clAtts = map ooAttr (filter (\x -> source x == root) attribs)
+                                , clMths = []
+                                }
+                       | root <- roots]
+                    ,assocs  = 
+                       [ OOAssoc { assSrc = Left (source r)
+                                 , assSrcPort = (name.head.declsUsedIn) r
+                                 , asslhm = (mults.flp) r
+                                 , asslhr = ""
+                                 , assTrg = Left (target r)
+                                 , assrhm = mults r
+                                 , assrhr = (name.head.declsUsedIn) r
+                                 }
+                       | r <- allrels, target r `elem` roots
+                       ]
+                    ,aggrs   = []
+                    ,geners  = []
+                    ,ooCpts  = roots
+                    }
+
+    where
+      ooAttr r = OOAttr { attNm = (name.head.declsUsedIn) r
+                        , attTyp = (name.target) r
+                        , attOptional = (not.isTot) r
+                        }
+      mults r = let minVal = if isTot r then MinOne else MinZero
+                    maxVal = if isInj r then MaxOne else MaxMany
+                in  Mult minVal maxVal 
+      allrels = [ EDcD r -- restricted to those themes that must be printed.
+                | r <- (nub.concat)
+                       ([declarations p ++ declsUsedIn p  | p <- pattsInScope fSpec ]++
+                        [declarations p ++ declsUsedIn p  | p <- procsInScope fSpec ])
+               , decusr r]
+      attribs = map flipWhenInj (filter isAttribRel allrels)
+          where isAttribRel r = isUni r || isInj r
+                flipWhenInj r = if isInj r then flp r else r
+      roots = nub (map source allrels)
+                     
+   -- | This function generates a technical data model.
+   -- It is based on the plugs that are calculated.
+   tdAnalysis :: Fspc -> Options -> ClassDiag
+   tdAnalysis fSpec _ = 
+     OOclassdiagram {cdName  = "technical_"++name fSpec
+                    ,classes = 
+                       [ OOClass{ clName = sqlname table
+                                , clcpt  = primKey table
+                                , clAtts = case table of
+                                              TblSQL{fields=attribs
+                                                    ,mLkpTbl=t} -> map (ooAttr.lookInFor t.fldexpr) attribs
+                                              BinSQL{columns=(a,b)}      -> 
+                                                 [OOAttr { attNm       = fldname a
+                                                         , attTyp      = (name.target.fldexpr) a
+                                                         , attOptional = False
+                                                         }
+                                                 ,OOAttr { attNm       = fldname b
+                                                         , attTyp      = (name.target.fldexpr) b
+                                                         , attOptional = False
+                                                         }
+                                                 ]
+                                              _     -> fatal 166 "Unexpeced type of table!"
+                                , clMths = []
+                                }
+                       | table <- tables]
+                    ,assocs  = allAssocs
+                    ,aggrs   = []
+                    ,geners  = []
+                    ,ooCpts  = roots
+                    }
+     where
+      lookInFor [] _ = fatal 191 "Expression not found!"
+      lookInFor ((expr,_,t):xs) a 
+                 | expr == a = t
+                 | otherwise = lookInFor xs a 
+      tables = [ pSql | InternalPlug pSql <- plugInfos fSpec, not (isScalar pSql)]
+         where isScalar ScalarSQL{} = True
+               isScalar _           = False 
+      roots :: [A_Concept]
+      roots = catMaybes (map primKey tables)
+      primKey TblSQL{fields=(f:_)} = Just (source (fldexpr f))
+      primKey _                    = Nothing
+      ooAttr :: SqlField -> CdAttribute
+      ooAttr f= OOAttr { attNm = fldname f 
+                       , attTyp = (name.target.fldexpr) f
+                       , attOptional = fldnull f
+                       }
+      allAssocs = [a | a<-concatMap relsOf tables
+                     , hasRootTarget a
+                  ]
+        where
+          hasRootTarget a = case assTrg a of
+                               Left c ->  c `elem`  kernelConcepts
+                               Right _ -> False
+          kernelConcepts = map fst (concatMap cLkpTbl tables)
+          rootOf c = head [(source.fldexpr.snd.head.cLkpTbl) t | t<-tables, c `elem` map fst ( cLkpTbl t)]
+          relsOf t = 
+            case t of
+              TblSQL{} -> map mkRel (catMaybes [relOf fld | fld <- fields t])
+              BinSQL{columns=(a,b)} -> 
+                        [ OOAssoc { assSrc = Right (sqlname t)
+                                  , assSrcPort = fldname a
+                                  , asslhm = Mult MinZero MaxMany
+                                  , asslhr = ""
+                                  , assTrg = (Left .target.fldexpr) a
+                                  , assrhm = Mult MinOne MaxOne
+                                  , assrhr = ""
+                                  }
+                        , OOAssoc { assSrc = Right (sqlname t)
+                                  , assSrcPort = fldname b
+                                  , asslhm = Mult MinZero MaxMany
+                                  , asslhr = ""
+                                  , assTrg = (Left .target.fldexpr) b
+                                  , assrhm = Mult MinOne MaxOne
+                                  , assrhr = ""
+                                  }
+                        ]
+              _  -> fatal 195 "Unexpeced type of table!"
+          relOf f = 
+            let expr = fldexpr f in
+            case expr of
+              EDcI{} -> Nothing
+              EDcD d -> if target d `elem` kernelConcepts then Just (expr,f) else Nothing
+              EFlp (EDcD d) -> if source d `elem` kernelConcepts then Just (expr,f) else Nothing
+              _ -> fatal 200 ("Unexpected expression: "++show expr)
+          mkRel :: (Expression,SqlField) -> Association
+          mkRel (expr,f) =
+               OOAssoc { assSrc = Left (source expr)
+                       , assSrcPort = fldname f
+                       , asslhm = (mults.flp) expr
+                       , asslhr = fldname f
+                       , assTrg = Left (rootOf (target expr))
+                       , assrhm = mults expr
+                       , assrhr = (name.head.declsUsedIn) expr
+                       }
+      mults r = let minVal = if isTot r then MinOne else MinZero
+                    maxVal = if isInj r then MaxOne else MaxMany
+                in  Mult minVal maxVal 
+
+
+---- In order to make classes, all relations that are univalent and injective are flipped
+---- attRels contains all relations that occur as attributes in classes.
+--       attRels    = [r |r<-rels, isUni r, not (isInj r)]        ++[flp r |r<-rels, not (isUni r), isInj r] ++
+--                    [r |r<-rels, isUni r,      isInj r, isSur r]++[flp r |r<-rels,      isUni r , isInj r, not (isSur r)]
+---- assRels contains all relations that do not occur as attributes in classes
+--       assRels    = [r |r<-relsLim, not (isUni r), not (isInj r)]
+--       attrs rs   = [ OOAttr ((name.head.declsUsedIn) r) (name (target r)) (not(isTot r))
+--                    | r<-rs, not (isPropty r)]
+--       isPropty r = null([Sym,Asy]>-multiplicities r)
+       
+   -- | translate a ClassDiagram to a DotGraph, so it can be used to show it as a picture. 
+   classdiagram2dot :: Options -> ClassDiag -> DotGraph String
+   classdiagram2dot flags cd
+    = DotGraph { strictGraph   = False
+               , directedGraph = True
+               , graphID       = Nothing
+               , graphStatements = dotstmts
+               }
+        where
+         dotstmts = DotStmts
+           { attrStmts =  [ GraphAttrs [ RankDir FromLeft
+                                       , bgColor White]
+                          ]
+                   --    ++ [NodeAttrs  [ ]]
+                       ++ [EdgeAttrs  [ FontSize 11
+                                      , MinLen 4
+                          ]           ]
+           , subGraphs = []
+           , nodeStmts = allNodes (classes cd) (nodes cd >- nodes (classes cd))
+           , edgeStmts = (map association2edge (assocs cd))  ++
+                         (map aggregation2edge (aggrs cd))  ++
+                         (concatMap generalization2edges (geners cd))
+           }
+        
+        
+          where
+          allNodes :: [Class] -> [String] -> [DotNode String]
+          allNodes cs others = 
+             map class2node cs ++ 
+             map nonClass2node others
+          
+          class2node :: Class -> DotNode String
+          class2node cl = DotNode 
+            { nodeID         = name cl
+            , nodeAttributes = [ Shape PlainText
+                               , GVcomp.Color [WC (X11Color Purple) Nothing]
+                               , Label (HtmlLabel (Table htmlTable))
+                               ]
+            } where 
+             htmlTable = HTable { tableFontAttrs = Nothing
+                                , tableAttrs     = [ Html.BGColor (X11Color White)
+                                                   , Html.Color (X11Color Black) -- the color used for all cellborders
+                                                   , Html.Border 0  -- 0 = no border
+                                                   , CellBorder 1  
+                                                   , CellSpacing 0
+                                                   ]
+                                , tableRows      = [ Cells -- Header row, containing the name of the class
+                                                      [ LabelCell 
+                                                            [ Html.BGColor (X11Color Gray10)
+                                                            , Html.Color   (X11Color Black)
+                                                            ]
+                                                            (Html.Text [ Html.Font [ Html.Color   (X11Color White)
+                                                                                 ]                                                            
+                                                                                 [Html.Str (fromString (name cl))]
+                                                                      ]
+                                                            )
+                                                      ]
+                                                   ]++ 
+                                                   map attrib2row (clAtts cl) ++
+                                                   map method2row (clMths cl) 
+                                                   
+                                                   
+                                } 
+                 where
+                   attrib2row a = Cells
+                                    [ Html.LabelCell [ Html.Align HLeft
+                                                     , (Port .PN .fromString) (attNm a)
+                                                     ] 
+                                         ( Html.Text [ Html.Str (fromString (if attOptional a then "o " else "+ "))
+                                                     , Html.Str (fromString (name a))
+                                                     , Html.Str (fromString " : ")
+                                                     , Html.Str (fromString (attTyp a))
+                                                     ]
+                                         ) 
+                                    ]
+                   method2row m = Cells
+                                    [ Html.LabelCell [ Html.Align HLeft] 
+                                         ( Html.Text [ Html.Str (fromString "+ ")
+                                                     , Html.Str (fromString (show m))
+                                                     ]
+                                         ) 
+                                    ]
+                    
+          nonClass2node :: String -> DotNode String
+          nonClass2node str = DotNode { nodeID = str
+                                      , nodeAttributes = [ Shape Box3D
+                                                         , Label (StrLabel (fromString str))
+                                                         ]
+                                      }
+          
+  -------------------------------
+  --        ASSOCIATIONS:      --
+  -------------------------------
+          association2edge :: Association -> DotEdge String
+          association2edge ass = 
+             DotEdge { fromNode       = (case assSrc ass of
+                                          Left c  -> name c
+                                          Right s -> s)
+                     , toNode         = case assTrg ass of
+                                          Left c  -> name c
+                                          Right s -> s
+                     , edgeAttributes = [ ArrowHead (AType [(ArrMod OpenArrow BothSides, NoArrow)])  -- No arrowHead
+                                        , ArrowTail (AType [(ArrMod OpenArrow BothSides, NoArrow)])  -- No arrowTail
+                                        , HeadLabel (mult2Lable (assrhm ass))
+                                        , TailLabel (mult2Lable (asslhm ass))
+                                        , Label     (StrLabel (fromString (assrhr ass)))
+                                        , LabelFloat True
+                                        ]
+                                      ++[(TailPort (LabelledPort (PN ((fromString.assSrcPort) ass)) Nothing))]
+                     }
+              where
+                 mult2Lable = StrLabel . fromString . mult2Str
+                 mult2Str (Mult MinZero MaxOne)  = "0-1"
+                 mult2Str (Mult MinZero MaxMany) = "*"
+                 mult2Str (Mult MinOne  MaxOne)  = "1"
+                 mult2Str (Mult MinOne  MaxMany) = "1-*"
+                  
+  -------------------------------
+  --        AGGREGATIONS:      --
+  -------------------------------
+          aggregation2edge :: Aggregation -> DotEdge String
+          aggregation2edge agg =
+             DotEdge { fromNode       = (name.aggSrc) agg
+                     , toNode         = (name.aggTrg) agg
+                     , edgeAttributes = [ ArrowHead (AType [(ArrMod OpenArrow BothSides, NoArrow)])  -- No arrowHead
+                                        , ArrowTail (AType [(ArrMod (case aggDel agg of 
+                                                                      Open -> OpenArrow
+                                                                      Close -> FilledArrow
+                                                                    ) BothSides , Diamond)
+                                                           ]) 
+                                        ]
+                     }
+                 
+ 
+ 
+  -------------------------------
+  --        GENERALIZATIONS:   --       -- Ampersand statements such as "GEN Dolphin ISA Animal" are called generalization.
+  --                           --       -- Generalizations are represented by a red arrow with a (larger) open triangle as arrowhead 
+  -------------------------------
+          generalization2edges :: Generalization -> [DotEdge String]
+          generalization2edges ooGen = map (sub2edge (genGen ooGen)) (genSubs ooGen)
+           where
+             sub2edge g s = DotEdge
+                              { fromNode = name g
+                              , toNode   = name s
+                              , edgeAttributes 
+                                         = [ ArrowTail (AType [(ArrMod OpenArrow BothSides, NoArrow)])  -- No arrowTail
+                                           , ArrowHead (AType [(ArrMod OpenArrow BothSides, Normal)])   -- Open normal arrowHead
+                                           , ArrowSize  2.0
+                                           ] ++
+                                           ( if blackWhite flags
+                                             then [Style [SItem Dashed []]]
+                                             else [GVcomp.Color [WC (X11Color Red) Nothing]]
+                                           )
+                              }
+             
+
+
+
+-------------- Class Diagrams ------------------
+   data ClassDiag = OOclassdiagram {cdName :: String
+                                   ,classes :: [Class]           --
+                                   ,assocs :: [Association]      --
+                                   ,aggrs ::  [Aggregation]      --
+                                   ,geners :: [Generalization]   --
+                                   ,ooCpts :: [A_Concept]}
+                            deriving Show
+   instance Identified ClassDiag where
+      name = cdName
+        
+   data Class          = OOClass  { clName :: String          -- ^ name of the class
+                                  , clcpt ::  Maybe A_Concept -- ^ Main concept of the class. (link tables do not have a main concept)
+                                  , clAtts :: [CdAttribute]   -- ^ Attributes of the class
+                                  , clMths :: [Method]        -- ^ Methods of the class
+                                  } deriving Show
+   instance Identified Class where
+      name = clName
+   data CdAttribute    = OOAttr   { attNm :: String            -- ^ name of the attribute
+                                  , attTyp :: String           -- ^ type of the attribute (Concept name or built-in type)
+                                  , attOptional :: Bool        -- ^ says whether the attribute is optional
+                                  } deriving Show
+   instance Identified CdAttribute where
+      name = attNm
+   data MinValue = MinZero | MinOne deriving (Show, Eq)
+   
+   data MaxValue = MaxOne | MaxMany deriving (Show, Eq)
+   
+   data Multiplicities = Mult MinValue MaxValue deriving Show
+   
+   data Association    = OOAssoc  { assSrc :: Either A_Concept String -- ^ source: the left hand side class. In case of a link table, the name of that table.
+                                  , assSrcPort :: String       -- ^ the name of the field in the source table
+                                  , asslhm :: Multiplicities   -- ^ left hand side multiplicities
+                                  , asslhr :: String           -- ^ left hand side role
+                                  , assTrg :: Either A_Concept String -- ^ target: the right hand side class. In case of a link table, the name of that table.
+                                  , assrhm :: Multiplicities   -- ^ right hand side multiplicities
+                                  , assrhr :: String           -- ^ right hand side role
+                                  }  deriving Show
+   data Aggregation    = OOAggr   { aggDel :: Deleting         -- 
+                                  , aggSrc :: A_Concept           --
+                                  , aggTrg :: A_Concept           --
+                                  } deriving (Show, Eq)
+   data Generalization = OOGener  { genGen :: A_Concept             --
+                                  , genSubs:: [A_Concept]           --
+                                  } deriving (Show, Eq)
+
+
+
+   data Deleting       = Open | Close                      --
+                                    deriving (Show, Eq)
+   data Method         = OOMethodC      String             -- name of this method, which creates a new object (producing a handle)
+                                        [CdAttribute]      -- list of parameters: attribute names and types
+                       | OOMethodR      String             -- name of this method, which yields the attribute values of an object (using a handle).
+                                        [CdAttribute]      -- list of parameters: attribute names and types
+                       | OOMethodS      String             -- name of this method, which selects an object using key attributes (producing a handle).
+                                        [CdAttribute]      -- list of parameters: attribute names and types
+                       | OOMethodU      String             -- name of this method, which updates an object (using a handle).
+                                        [CdAttribute]      -- list of parameters: attribute names and types
+                       | OOMethodD      String             -- name of this method, which deletes an object (using nothing but a handle).
+                       | OOMethod       String             -- name of this method, which deletes an object (using nothing but a handle).
+                                        [CdAttribute]      -- list of parameters: attribute names and types
+                                        String             -- result: a type
+
+   instance Show Method where
+    showsPrec _ (OOMethodC nm cs)  = showString (nm++"("++intercalate "," [ n | OOAttr n _ _<-cs]++"):handle")
+    showsPrec _ (OOMethodR nm as)  = showString (nm++"(handle):["++intercalate "," [ n | OOAttr n _ _<-as]++"]")
+    showsPrec _ (OOMethodS nm ks)  = showString (nm++"("++intercalate "," [ n | OOAttr n _ _<-ks]++"):handle")
+    showsPrec _ (OOMethodD nm)     = showString (nm++"(handle)")
+    showsPrec _ (OOMethodU nm cs)  = showString (nm++"(handle,"++intercalate "," [ n | OOAttr n _ _<-cs]++")")
+    showsPrec _ (OOMethod nm cs r) = showString (nm++"("++intercalate "," [ n | OOAttr n _ _<-cs]++"): "++r)
+
+--
+--   testCD
+--    = OOclassdiagram
+--      [ OOClass "Plan" [ooAttr "afkomst" "Actor"] []
+--      , OOClass "Formulier" [ooAttr "plan" "Plan",ooAttr "van" "Actor",ooAttr "aan" "Actor",ooAttr "sessie" "Sessie"] []
+--      , OOClass "Dossier" [ooAttr "eigenaar" "Actor"] []
+--      , OOClass "Gegeven" [ooAttr "type" "Gegevenstype",ooAttr "in" "Dossier",ooAttr "veldnaam" "Veldnaam",ooAttr "waarde" "Waarde"] []
+--      , OOClass "Veld" [ooAttr "type" "Veldtype",ooAttr "waarde" "Waarde"] []
+--      , OOClass "Veldtype" [ooAttr "veldnaam" "Veldnaam",ooAttr "formuliertype" "Plan",ooAttr "gegevenstype" "Gegevenstype"] []
+--      , OOClass "Sessie" [ooAttr "dossier" "Dossier",ooAttr "uitgevoerd" "Actor"] []
+--      ]
+--      [ OOAssoc "Plan" "0..n" "" "Plan" "0..n" "stap"
+--      , OOAssoc "Formulier" "0..n" "" "Actor" "0..n" "inzage"
+--      , OOAssoc "Formulier" "0..n" "" "Formulier" "0..n" "in"
+--      , OOAssoc "Formulier" "0..n" "" "Plan" "0..n" "stap"
+--      , OOAssoc "Autorisatie" "0..n" "" "Actor" "0..n" "aan"
+--      , OOAssoc "Gegeven" "0..n" "" "Formulier" "0..n" "op"
+--      , OOAssoc "Gegeven" "0..n" "" "Actor" "0..n" "inzage"
+--      , OOAssoc "Actor" "0..n" "" "Actor" "0..n" "gedeeld"
+--      , OOAssoc "Formulier" "0..n" "" "Actor" "0..n" "inzagerecht"
+--      , OOAssoc "Gegeven" "0..n" "" "Actor" "0..n" "inzagerecht"
+--      , OOAssoc "Autorisatie" "0..n" "" "Gegeven" "0..n" "object"
+--      , OOAssoc "Actie" "0..n" "" "Gegeven" "0..n" "object"
+--      , OOAssoc "Autorisatie" "0..n" "" "Actie" "0..n" "op"
+--      , OOAssoc "Autorisatie" "0..n" "" "Actor" "0..n" "door"
+--      , OOAssoc "Actie" "0..n" "" "Actor" "0..n" "door"
+--      , OOAssoc "Veld" "0..n" "" "Gegeven" "0..n" "bindt"
+--      , OOAssoc "Sessie" "0..1" "" "Actor" "0..1" "actief"
+--      , OOAssoc "Formulier" "0..n" "" "Actor" "0..n" "openstaand"
+--      , OOAssoc "Gegeven" "0..n" "" "Actor" "0..n" "openstaand"
+--      ]
+--      [ OOAggr Close "Dossier" "Formulier"
+--      , OOAggr Close "Formulier" "Veld"
+--      ]
+--      []
+--      ("NoPat",[])
+--      where ooAttr nm t = OOAttr nm t True
+ src/lib/DatabaseDesign/Ampersand/Fspec/Graphic/Graphics.hs view
@@ -0,0 +1,400 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Fspec.Graphic.Graphics 
+          (Dotable(..), makePictureObj, printDotGraph, DrawingType(..)
+    --      ,GraphvizCommand(..)
+    --      ,GraphvizOutput(..)
+    --      ,runGraphvizCommand) 
+    )where
+-- TODO url links for atlas
+
+import Data.GraphViz hiding (addExtension )
+import DatabaseDesign.Ampersand.ADL1 
+import DatabaseDesign.Ampersand.Fspec.Fspec
+import DatabaseDesign.Ampersand.Classes 
+import DatabaseDesign.Ampersand.Fspec.Switchboard
+import DatabaseDesign.Ampersand.Misc
+import DatabaseDesign.Ampersand.Basics (fatalMsg,eqCl,Collection(..),Identified(..))
+import DatabaseDesign.Ampersand.Fspec.Graphic.Picture
+import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram (ClassDiag,classdiagram2dot)
+import Data.GraphViz.Attributes.Complete
+import Data.List (nub)
+import Data.String
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Fspec.Graphic.Graphics"
+
+class Identified a => Navigatable a where
+   interfacename :: a -> String
+   itemstring :: a -> String 
+   theURL :: Options -> a -> EscString    -- url of the web page in Atlas used when clicked on a node or edge in a .map file
+   theURL flags x 
+     = fromString ("Atlas.php?content=" ++ interfacename x
+                   ++  "&User=" ++ user
+                   ++  "&Script=" ++ script
+                   ++  "&"++interfacename x ++"="++qualify++itemstring x
+                  )
+      where --copied from atlas.hs
+      script = fileName flags
+      user = namespace flags
+      qualify = "("++user ++ "." ++ script ++ ")"  
+
+
+instance Navigatable A_Concept where
+   interfacename _ = "Concept" --see Atlas.adl
+   itemstring = name  --copied from atlas.hs
+ 
+instance Navigatable Declaration where 
+   interfacename _ = "Relatiedetails"
+   itemstring x = name x ++ "["
+                  ++ (if source x==target x then name(source x) else name(source x)++"*"++name(target x))
+                  ++ "]"
+
+data DrawingType
+      = Plain_CG   -- Plain Conceptual graph. No frills
+      | Rel_CG     -- Conceptual graph that focuses on relations
+      | Gen_CG     -- Conceptual graph that focuses on generalizations
+
+-- Chapter 1: All objects that can be transformed to a conceptual diagram are Dotable...
+class Identified a => Dotable a where
+   conceptualGraph :: Fspc
+                      -> Options              -- the options
+                      -> DrawingType          -- this parameter allows for different alternative graphs for the same a
+                      -> a -> DotGraph String -- yields a function that maps a to a DotGraph
+   -- makePicture is an abbreviation of three steps:
+   --  1. conceptualGraph:  creates a DotGraph data structure
+   --  2. printDotGraph:    makes a string, which is the contents of the dot-file for GraphViz
+   --  3. makePictureObj:   creates a Picture data structure, containing the required metadata needed for production.
+   makePicture :: Options
+               -> Fspc
+               -> DrawingType
+               -> a
+               -> Picture
+
+{- This instance of Dotable is meant for drawing data models -}
+instance Dotable ClassDiag where
+   conceptualGraph _ _ _ _ = fatal 58 "TODO: ClassDiagram moet nog netjes naar nieuwe Graphviz worden verbouwd."
+   makePicture flags _ _ cd =
+          makePictureObj flags (name cd) PTClassDiagram (classdiagram2dot flags cd) 
+
+instance Dotable A_Concept where
+   conceptualGraph fSpec flags _ c = conceptual2Dot flags (name c) cpts rels idgs
+         where 
+          rs    = [r | r<-udefrules fSpec, c `elem` concs r]
+          idgs  = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
+          gs    = fsisa fSpec
+-- TODO: removal of redundant isa edges might be done more efficiently
+          cpts  = nub$cpts' ++ [g |(s,g)<-gs, elem g cpts' || elem s cpts'] ++ [s |(s,g)<-gs, elem g cpts' || elem s cpts']
+          cpts' = concs rs
+          rels  = [r | r<-declsUsedIn rs   -- the use of "declsUsedIn" restricts relations to those actually used in rs
+                     , not (isProp r)    -- r is not a property
+                     ]
+   makePicture flags fSpec variant x =
+          (makePictureObj flags (name x) PTConcept . conceptualGraph fSpec flags variant) x
+
+instance Dotable Pattern where
+   -- | The Plain_CG of pat makes a picture of at least the declsUsedIn 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.
+   conceptualGraph fSpec flags Plain_CG pat = conceptual2Dot flags (name pat) cpts (rels `uni` xrels) idgs
+        where 
+         --DESCR -> get concepts and arcs from pattern
+          idgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts]    --  all isa edges within the concepts
+          gs   = fsisa fSpec 
+          cpts = let cpts' = concs pat `uni` concs rels
+                 in cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl] -- up to two more general concepts
+          rels = [r | r@Sgn{}<-declsUsedIn pat
+                    , not (isProp r)    -- r is not a property
+                    ]
+          -- extra rels to connect concepts without rels in this picture, but with rels in the fspec
+          xrels = 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)]
+                  in nub [r | c<-orphans, r@Sgn{}<-declarations fSpec
+                        , (c == source r && target r `elem` cpts) || (c == target r  && source r `elem` cpts)
+                        , source r /= target r, decusr r
+                        ]
+   -- | The Rel_CG of pat makes a picture of declarations and gens within pat only 
+   conceptualGraph fSpec flags Rel_CG pat = conceptual2Dot flags (name pat) cpts rels idgs
+        where 
+         --DESCR -> get concepts and arcs from pattern
+          idgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts]    --  all isa edges within the concepts
+          gs   = fsisa fSpec 
+          cpts = concs (declarations pat) `uni` concs (gens pat)
+          rels = [r | r@Sgn{}<-declarations pat
+                    , not (isProp r), decusr r    -- r is not a property
+                    ]
+   conceptualGraph fSpec flags Gen_CG pat = conceptual2Dot flags (name pat) cpts [] edges
+        where 
+         --DESCR -> get concepts and arcs from pattern
+          idgs  = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
+          gs    = fsisa fSpec 
+          edges = clos gs idgs
+          cpts  = concs edges
+          cpts' = concs pat >- concs gs
+          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
+   makePicture flags fSpec variant pat =
+          (makePictureObj flags (name pat) PTPattern . conceptualGraph fSpec flags variant) pat
+
+instance Dotable FProcess where
+   conceptualGraph fSpec flags _ fproc = conceptual2Dot flags (name fproc) cpts rels idgs
+        where 
+         --DESCR -> get concepts and arcs from process
+          idgs  = [(s,g) |(s,g)<-gs,  g `elem` cpts']  --  all isa edges
+          gs    = fsisa fSpec 
+          cpts  = nub(cpts' ++ [g |(g,_)<-idgs] ++ [s |(_,s)<-idgs])
+          cpts' = concs (fpProc fproc)
+          rels  = [r | r@Sgn{}<-declsUsedIn (fpProc fproc), decusr r
+                     , not (isProp r)    -- r is not a property
+                     ]
+   makePicture flags _ _ x =
+          (makePictureObj flags (name x) PTProcess . processModel) x
+{- inspired by:
+   makePicture flags _ _ cd =
+          makePictureObj flags (name cd) PTClassDiagram (classdiagram2dot flags cd) -}
+
+instance Dotable Activity where
+   conceptualGraph fSpec flags _ ifc = conceptual2Dot flags (name ifc) cpts rels idgs
+         where
+         -- involve all rules from the specification that are affected by this interface
+          rs         = [r | r<-udefrules fSpec, affected r]
+          affected r = not (null (declsUsedIn r `isc` declsUsedIn ifc))
+         -- involve all isa links from concepts touched by one of the affected rules
+          idgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts']  --  all isa edges
+          gs   = fsisa fSpec
+         -- involve all concepts involved either in the affected rules or in the isa-links
+          cpts = nub $ cpts' ++ [c |(s,g)<-idgs, c<-[g,s]]
+          cpts'  = concs rs
+          rels = [r | r@Sgn{}<-declsUsedIn ifc, decusr r
+                    , not (isProp r)    -- r is not a property
+                    ]
+   makePicture flags fSpec variant x =
+          (makePictureObj flags (name x) PTFinterface . conceptualGraph fSpec flags variant) x
+
+instance Dotable SwitchBdDiagram where
+   conceptualGraph _ _ _ = sbdotGraph
+   makePicture flags fSpec variant x =
+          (makePictureObj flags (name x) PTSwitchBoard . conceptualGraph fSpec flags variant) x
+
+instance Dotable Rule where
+   conceptualGraph fSpec flags _ r = conceptual2Dot flags (name r) cpts rels idgs
+    where 
+     idgs = [(s,g) | (s,g)<-fsisa fSpec
+                   , g `elem` concs r || s `elem` concs r]  --  all isa edges
+     cpts = nub $ concs r++[c |(s,g)<-idgs, c<-[g,s]]
+     rels = [d | d@Sgn{}<-declsUsedIn r, decusr d
+               , not (isProp d)    -- d is not a property
+               ]
+   makePicture flags fSpec variant x =
+          (makePictureObj flags (name x)  PTRule . conceptualGraph fSpec flags variant) x
+
+-- Chapter 2: Formation of a conceptual graph as a DotGraph data structure.
+conceptual2Dot :: Options                   -- ^ the flags 
+               -> String                    -- ^ the name of the Graph
+               -> [A_Concept]               -- ^ The concepts to draw in the graph
+               -> [Declaration]   -- ^ The relations, (the edges in the graph)
+               -> [(A_Concept, A_Concept)]  -- ^ list of Isa relations 
+               -> DotGraph String           -- ^ The resulting DotGraph
+conceptual2Dot flags graphName cpts' rels idgs
+     = DotGraph { strictGraph = False
+                , directedGraph = True
+                , graphID = Just (Str (fromString graphName))
+                , graphStatements 
+                      = DotStmts { attrStmts = [GraphAttrs (handleFlags TotalPicture flags)]
+                                 , subGraphs = []
+                                 , nodeStmts = conceptNodes ++ relationNodes
+                                 , edgeStmts = relationEdges ++ isaEdges
+                                 }
+                }
+       where
+        cpts = cpts' `uni` concs rels `uni` concs idgs
+        conceptNodes = [constrNode (baseNodeId c) (CptOnlyOneNode c) flags | c<-cpts]
+        (relationNodes,relationEdges) = (concat a, concat b) 
+              where (a,b) = unzip [relationNodesAndEdges r | r<-zip rels [1..]]
+        isaEdges = [constrEdge (baseNodeId s) (baseNodeId g) IsaOnlyOneEdge  flags | (s,g)<-idgs]
+              
+        baseNodeId :: A_Concept -> String  -- returns the NodeId of the node where edges to this node should connect to. 
+        baseNodeId c 
+            = case lookup c (zip cpts [(1::Int)..]) of
+                Just i -> "cpt_"++show i
+                _      -> fatal 169 $ "element "++name c++" not found by nodeLabel."
+
+        -- | This function constructs a list of NodeStatements that must be drawn for a concept.
+        relationNodesAndEdges ::
+             (Declaration,Int)           -- ^ tuple contains the declaration and its rank
+          -> ([DotNode String],[DotEdge String]) -- ^ the resulting tuple contains the NodeStatements and EdgeStatements
+        relationNodesAndEdges (r,n)
+          | doubleEdges flags
+             = (  [ relNameNode ]    -- node to place the name of the relation
+               ,  [ constrEdge (baseNodeId (source r)) (nodeID relNameNode)   (RelSrcEdge r) flags     -- edge to connect the source with the hinge
+                  , constrEdge (nodeID relNameNode)   (baseNodeId (target r)) (RelTgtEdge r) flags]     -- edge to connect the hinge to the target
+               )
+          | otherwise
+               = ( [] --No intermediate node
+                 , [constrEdge (baseNodeId (source r)) (baseNodeId (target r)) (RelOnlyOneEdge r)  flags]
+                 )
+          where
+        --    relHingeNode   = constrNode ("relHinge_"++show n) RelHingeNode   flags
+            relNameNode    = constrNode ("relName_"++show n) (RelIntermediateNode r) flags
+                                   
+constrNode :: a -> PictureObject -> Options -> DotNode a
+constrNode nodeId pObj flags
+  = DotNode { nodeID = nodeId
+            , nodeAttributes = [ FontSize 10
+                               , FontName (fromString(pangoFont flags))
+                           --    , Width 0.1
+                           --    , Height  0.1
+                               ]++handleFlags pObj flags
+            }
+
+constrEdge :: a -> a -> PictureObject -> Options -> DotEdge a
+constrEdge nodeFrom nodeTo pObj flags 
+  = DotEdge { fromNode = nodeFrom
+            , toNode   = nodeTo
+            , edgeAttributes = [ FontSize 12
+                               , FontName (fromString(pangoFont flags))
+                               , Dir Forward
+                            --   , LabelAngle (-25.0)
+                               , Color [WC(X11Color Gray35)Nothing]
+                               , LabelFontColor (X11Color Black)
+                               , LabelFloat False
+                               , Decorate False
+                            --   , LabelDistance 2.0
+                            --   , (HeadLabel . StrLabel . fromString) "Test"
+                               ]++handleFlags pObj flags
+            }
+--DESCR -> a picture consists of arcs (relations), concepts, and ISA relations between concepts
+--         arcs are attached to a source or target concept
+--         arcs and concepts are points attached to a label
+-- for Haddock support on GraphViz, click on:
+--       http://hackage.haskell.org/packages/archive/graphviz/2999.6.0.0/doc/html/doc-index.html     or
+--       http://hackage.haskell.org/packages/archive/graphviz/latest/doc/html/doc-index.html
+
+data PictureObject = CptOnlyOneNode A_Concept    -- ^ Node of a concept that serves as connector and shows the name
+                   | CptConnectorNode A_Concept  -- ^ Node of a concept that serves as connector of relations to that concept
+                   | CptNameNode A_Concept       -- ^ Node of a concept that shows the name
+                   | CptEdge                     -- ^ Edge of a concept to connect its nodes
+                   | RelOnlyOneEdge Declaration  -- ^ Edge of a relation that connects to the source and the target
+                   | RelSrcEdge     Declaration  -- ^ Edge of a relation that connects to the source
+                   | RelTgtEdge     Declaration  -- ^ Edge of a relation that connects to the target
+                   | RelIntermediateNode    Declaration  -- ^ Intermediate node, as a hindge for the relation edges
+                   | IsaOnlyOneEdge              -- ^ Edge of an ISA relation without a hinge node
+                   | TotalPicture                -- ^ Graph attributes
+         
+handleFlags :: PictureObject  -> Options -> [Attribute]
+handleFlags po flags = 
+    case po of
+      CptConnectorNode c 
+         -> if crowfoot flags
+            then 
+                 [ (Label . StrLabel . fromString . name) c
+                 , Shape PlainText
+                 , Style [filled]
+                 , URL (theURL flags c)
+                 ]
+            else [ Shape PointShape
+                 , Style [filled]
+                 ]
+      CptNameNode c  -> if crowfoot flags
+                        then [ Shape PointShape
+                             , Style [invis]]
+                        else 
+                             [ (Label . StrLabel . fromString . name) c
+                             , Shape PlainText
+                             , Style [filled]
+                             , URL (theURL flags c)
+                             ]
+      CptEdge    -> [Style [invis]
+                    ]
+      CptOnlyOneNode c -> 
+                          [(Label . StrLabel . fromString . name) c
+                          , Shape BoxShape
+                          , Style [filled] 
+                          , URL (theURL flags c)
+                          ]
+      RelOnlyOneEdge r -> [ URL (theURL flags r)
+                          , (XLabel . StrLabel .fromString.name) r
+                          ]
+                    --    ++[ (HeadLabel . StrLabel .fromString) "1" | isTot r && isUni r]
+                    --    ++[ (TailLabel . StrLabel .fromString) "1" | isSur r && isInj r]
+                        ++[ ArrowTail noArrow, ArrowHead noArrow
+                          , Dir Forward  -- Note that the tail arrow is not supported , so no crowfoot notation possible with a single edge.
+                          , Style [SItem Tapered []] , PenWidth 5
+                          ]
+      RelSrcEdge r -> [ ArrowHead ( if crowfoot flags  then normal                    else
+                                    if isFunction r    then noArrow                   else
+                                    if isInvFunction r then noArrow                   else
+                                    noArrow
+                                  )
+                      , ArrowTail ( if crowfoot flags  then crowfootArrowType False r else
+                                    if isFunction r    then noArrow                   else
+                                    if isInvFunction r then normal                    else
+                                    noArrow
+                                  )
+                      ,HeadClip False
+                --      , Dir Both  -- Needed because of change in graphviz. See http://www.graphviz.org/bugs/b1951.html
+                      ]
+      RelTgtEdge r -> [ (Label . StrLabel . fromString . name) r
+                      , ArrowHead ( if crowfoot flags  then crowfootArrowType True r  else
+                                    if isFunction r    then normal                    else
+                                    if isInvFunction r then noArrow                   else
+                                    noArrow
+                                  )
+                      , ArrowTail ( if crowfoot flags  then noArrow                   else
+                                    if isFunction r    then noArrow                   else
+                                    if isInvFunction r then AType [(noMod ,Inv)]      else
+                                    AType [(noMod ,Inv)]
+                                  )
+                   --   , Dir Both  -- Needed because of change in graphviz. See http://www.graphviz.org/bugs/b1951.html
+                      ,TailClip False
+                      ] 
+      RelIntermediateNode r -> 
+                       [ Label (StrLabel (fromString("")))
+                       , Shape PlainText
+                       , bgColor White
+                       , URL (theURL flags r) 
+                       ]
+      IsaOnlyOneEdge-> [ ArrowHead (AType [(open,Normal)])
+                       , ArrowTail noArrow
+                       , if blackWhite flags then Style [dotted] else Color [WC(X11Color Red)Nothing]
+                       ]
+      TotalPicture -> [ Sep (DVal (if doubleEdges flags then 1/2 else 2)) -- The minimal amount of whitespace between nodes
+                      , OutputOrder  EdgesFirst --make sure the nodes are always on top...
+                      , Overlap ScaleXYOverlaps
+                      , Splines PolyLine  -- SplineEdges could work as well.
+                      , Landscape False
+                      ]
+
+isInvFunction :: Declaration -> Bool
+isInvFunction d = isInj d && isSur d
+
+
+crowfootArrowType :: Bool -> Declaration -> ArrowType
+crowfootArrowType isHead r 
+   = AType (case isHead of
+               True  -> getCrowfootShape (isUni r) (isTot r)
+               False -> getCrowfootShape (isInj r) (isSur r)
+           )
+       where 
+         getCrowfootShape :: Bool -> Bool -> [( ArrowModifier , ArrowShape )]
+         getCrowfootShape a b =
+           case (a,b) of
+            (True ,True ) -> [my_tee          ]
+            (False,True ) -> [my_crow, my_tee ]
+            (True ,False) -> [my_odot, my_tee ]
+            (False,False) -> [my_crow, my_odot]
+             
+         my_tee :: ( ArrowModifier , ArrowShape )
+         my_tee = ( noMod , Tee )
+         my_odot :: ( ArrowModifier , ArrowShape )
+         my_odot= ( open, DotArrow )
+         my_crow :: ( ArrowModifier , ArrowShape )
+         my_crow= ( open, Crow )
+
+noMod :: ArrowModifier
+noMod = ArrMod { arrowFill = FilledArrow
+               , arrowSide = BothSides
+               }
+open :: ArrowModifier
+open  = noMod {arrowFill = OpenArrow}
+ src/lib/DatabaseDesign/Ampersand/Fspec/Graphic/Picture.hs view
@@ -0,0 +1,135 @@+{-# OPTIONS_GHC -Wall #-}
+-- This module is for the definition of Picture and PictureList.
+module DatabaseDesign.Ampersand.Fspec.Graphic.Picture
+    ( Picture(origName,uniqueName,caption,relPng,pType,scale) -- Other fields are hidden, for there is no need for them outside this module...
+    , Pictures,PictType(..),uniquePicName
+    , makePictureObj,writePicture
+    )
+where
+import System.FilePath   -- (replaceExtension,takeBaseName, (</>) )
+import System.Directory
+import DatabaseDesign.Ampersand.Misc
+import Control.Monad
+import DatabaseDesign.Ampersand.Basics  
+import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)
+import Data.GraphViz.Types.Canonical
+import Data.GraphViz.Commands
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Fspec.Graphic.Picture"
+
+type Pictures = [Picture]
+data Picture = Pict { origName :: String              -- ^ The original name of the object this picture was made for. (could include spaces!)
+                    , pType :: PictType               -- ^ 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.
+                    , uniqueName :: String            -- ^ used to reference the picture in pandoc or tex
+                    , dotSource :: DotGraph String    -- ^ the string representing the .dot
+                    , fullPath :: FilePath            -- ^ the full file path where the .dot and .png file resides
+                    , relPng :: FilePath              -- ^ the relative file path where the .png file resides
+                    , dotProgName :: GraphvizCommand  -- ^ the name of the program to use  ("dot" or "neato" or "fdp")
+                    , caption :: String               -- ^ a human readable name of this picture
+                    }
+data PictType = PTClassDiagram -- a UML class diagram, or something that comes close
+              | PTPattern      -- a conceptual diagram with the relations USED in a pattern
+              | PTFullPat      -- a conceptual diagram with the relations DECLARED in a pattern
+              | PTProcess      -- a process diagram, that shows dependencies between activities
+              | PTProcLang     -- a conceptual diagram that shows the language of a process
+              | PTConcept      -- a conceptual diagram that shows a concept in relation with the rules it occurs in.
+              | PTRule         -- a conceptual diagram that shows a rule
+              | PTSwitchBoard
+              | PTFinterface deriving Eq
+picType2prefix :: PictType -> String
+picType2prefix pt = case pt of
+                      PTClassDiagram -> "CD_"
+                      PTPattern      -> "Pat_"
+                      PTFullPat      -> "Lat_"
+                      PTProcess      -> "Proc_"
+                      PTProcLang     -> "PL_"
+                      PTConcept      -> "Cpt_"
+                      PTRule         -> "Rul_"
+                      PTSwitchBoard  -> "SB_"
+                      PTFinterface   -> "Serv_"
+
+makePictureObj :: Options
+               -> String           -- Name of the picture
+               -> PictType         -- Type of the picture
+               -> DotGraph String  -- The dot source. Should be canonnical.
+               -> Picture  -- The ADT of a picture
+makePictureObj flags nm pTyp dotsource
+    = Pict { origName    = nm
+           , uniqueName  = cdName
+           , dotSource   = dotsource
+           , fullPath    = absImgPath </> cdName 
+           , relPng      = relImgPath </> cdName
+           , pType       = pTyp
+           , scale       = case pTyp of
+                            PTClassDiagram -> "1.0"
+                            PTPattern      -> "0.7"
+                            PTFullPat      -> "0.5"
+                            PTProcess      -> "0.4"
+                            PTSwitchBoard  -> "0.4"
+                            PTProcLang     -> "0.7"
+                            _              -> "0.7"
+           , dotProgName = case pTyp of
+                     PTClassDiagram -> Dot
+                     PTSwitchBoard  -> Dot
+                     _              -> Fdp
+           , caption     = case (pTyp,language flags) of
+                           (PTClassDiagram,English) -> "Class Diagram of " ++ nm
+                           (PTClassDiagram,Dutch  ) -> "Klassediagram van " ++ nm
+                           (PTPattern     ,English) -> "Concept diagram of the rules in " ++ nm
+                           (PTPattern     ,Dutch  ) -> "Conceptueel diagram van de regels in " ++ nm
+                           (PTFullPat     ,English) -> "Concept diagram of relations in " ++ nm
+                           (PTFullPat     ,Dutch  ) -> "Conceptueel diagram van relaties in " ++ nm
+                           (PTProcess     ,English) -> "Process model of " ++ nm
+                           (PTProcess     ,Dutch  ) -> "Procesmodel van " ++ nm
+                           (PTSwitchBoard ,English) -> "Switchboard diagram of " ++ nm
+                           (PTSwitchBoard ,Dutch  ) -> "Schakelpaneel van " ++ nm
+                           (_             ,English) -> "Knowledge graph about " ++ nm
+                           (_             ,Dutch  ) -> "Kennisgraaf rond " ++ nm
+           }
+       where
+         absImgPath | genAtlas flags = dirPrototype flags </> relImgPath 
+                    | otherwise = dirOutput flags  </> relImgPath
+         relImgPath | genAtlas flags = "images" 
+                    | otherwise = []
+         cdName = uniquePicName pTyp nm
+--GMI voor Han -> (isAlpha c) verwijdert uit lijst comprehensie, dit gooit nummers (bv. rule nummers) uit de naam weg
+--       zodat alle ongelabelde rules de naam RUL_Rule hebben, dat is niet uniek.
+--       Deze functie garandeert sowieso geen uniekheid, is die garantie nodig?
+--       unieke namen voor (ConceptualGraph) datatypes zouden moeten worden gegarandeerd op het datatype als dat nodig is
+uniquePicName :: PictType -> String -> String
+uniquePicName pt nm = escapeNonAlphaNum (picType2prefix pt++nm)
+
+--         relImgPath = "img" </> user </> (baseName flags)
+--         user = takeWhile (/='.') (userAtlas flags)
+writePicture :: Options -> Picture -> IO()
+writePicture flags pict
+    = sequence_ (
+      [createDirectoryIfMissing True  (takeDirectory (fullPath pict))     |                   genAtlas flags ]++
+      [writeDot (dotProgName pict) Canon (dotSource pict) (fullPath pict) | genFspec flags || genAtlas flags ]++
+--      [writeDot (dotProgName pict) XDot  (dotSource pict) (fullPath pict) | genFspec flags || genAtlas flags ]++
+      [writeDot (dotProgName pict) Png   (dotSource pict) (fullPath pict) | genFspec flags || genAtlas flags ]++
+      [writeDot (dotProgName pict) Cmapx (dotSource pict) (fullPath pict) |                   genAtlas flags ]
+          )
+   where 
+     writeDot :: GraphvizCommand
+              -> GraphvizOutput
+              -> DotGraph String
+              -> FilePath
+              -> IO ()
+     writeDot gvCommand gvOutput graph filePath = 
+         do verboseLn flags ("Generating "++show gvOutput++" using "++show gvCommand++".")
+            path <- runGraphvizCommand gvCommand graph gvOutput (replaceExtension filePath (extentionOf gvOutput))
+            verboseLn flags (path++" written.")
+       where extentionOf :: GraphvizOutput -> String
+             extentionOf x = case x of
+                Canon -> "dot"
+                Png   -> "png"     
+                Cmapx -> "map"
+                XDot  -> "xdot"
+                Svg   -> "svg"
+                Gif   -> "gif"
+                _     -> fatal 139 "GraphvizOutput has undefined extention"
+             
+
+ src/lib/DatabaseDesign/Ampersand/Fspec/Motivations.hs view
@@ -0,0 +1,395 @@+{-# OPTIONS_GHC -Wall #-}
+--TODO -> Maybe this module is useful at more places than just func spec rendering.
+--        In that case it's not a Rendering module and it needs to be replaced
+module DatabaseDesign.Ampersand.Fspec.Motivations (Motivated(purposeOf,purposesDefinedIn,explanations,explForObj), Meaning(..))
+where
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+import DatabaseDesign.Ampersand.Fspec.Fspec(Fspc(..),FProcess(..), Activity(..)) -- TODO FProc should not be in here at the first place... It has been put here because of the removal of Activities from Process
+import DatabaseDesign.Ampersand.Basics
+import Text.Pandoc
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Fspec.Motivations"
+
+
+-- The general idea is that an Ampersand declaration such as:
+--     PURPOSE RELATION r[A*B] IN ENGLISH
+--     {+This text explains why r[A*B] exists-}
+-- produces the exact right text in the functional specification
+
+-- The class Motivated exists so that we can write the Haskell expression 'purposeOf fSpec l x'
+-- anywhere we like for every type of x that could possibly be motivated in an Purpose.
+-- 'purpose fSpec l x' produces all explanations related to x from the context (fSpec)
+--  that are available in the language specified in 'l'.
+-- The other functions in this class are solely meant to be used in the definition of purpose.
+-- They are defined once for each instance of Explainable, not be used in other code.
+-- TODO: Han, kan dat worden afgeschermd, zodat de programmeur alleen 'purpose' ziet en de andere functies
+--       dus niet kan gebruiken?
+--     @Stef: Ja, het is al zoveel mogelijk afgeschermd (zie definities die deze module exporteert, hierboven)
+--     maar er wordt nog gebruik van gemaakt voor oa foutmeldingen in de atlas, en het prototype.
+--     Zodra iemand iets anders verzint voor het gebruik van "ExplainOutputFormat(..),format",
+--     kunnen deze uit de export-list van deze module worden verwijderd.
+class  Identified a => Motivated a where 
+  purposeOf :: Fspc -> Lang -> a -> Maybe [Purpose] -- ^ explains the purpose of a, i.e. the reason why a exists. The purpose could be either given by the user, or generated by Ampersand. 
+                                                    --   Multiple purposes are allowed for the following reasons:
+                                                    --  * Different purposes from different sources make me want to document them all.
+                                                    --  * Combining two overlapping scripts from (i.e. from different authors) may cause multiple purposes.
+  purposeOf fSpec l x = case expls of
+                        []  -> Nothing -- fatal 40 "No purpose is generated! (should be automatically generated and available in Fspc.)"
+                        ps  -> Just ps
+                        
+   where expls = [e | e<-explanations fSpec
+                    , explForObj x (explObj e)                  -- informally: "if x and e are the same"
+                    , markupMatchesLang (explMarkup e)
+                 ] 
+         markupMatchesLang m = amLang m == l
+  explForObj :: a -> ExplObj -> Bool    -- ^ Given an Explainable object and an ExplObj, return TRUE if they concern the identical object.
+  explanations :: a -> [Purpose]  -- ^ The explanations that are defined inside a (including that of a itself)
+  purposesDefinedIn :: Fspc -> Lang -> a -> [Purpose]  -- ^ The explanations that are defined inside a (including that of a itself)
+  purposesDefinedIn fSpec l x
+   = [e | e<-explanations fSpec
+        , amLang (explMarkup e) == l
+        , explForObj x (explObj e)                  -- informally: "if x and e are the same"
+     ]
+instance Motivated ConceptDef where
+--  meaning _ cd = fatal 49 ("Concept definitions have no intrinsic meaning, (used with concept definition of '"++cdcpt cd++"')")
+  explForObj x (ExplConceptDef x') = x == x'
+  explForObj _ _ = False
+  explanations _ = []
+  
+instance Motivated A_Concept where
+--  meaning _ c = fatal 54 ("Concepts have no intrinsic meaning, (used with concept '"++name c++"')")
+  explForObj x (ExplConceptDef cd) = name x == name cd
+  explForObj _ _ = False
+  explanations _ = []
+
+instance Motivated Declaration where
+--  meaning l decl = if null (decMean decl)
+--                   then concat [explCont expl | expl<-autoMeaning l decl, Just l == explLang expl || Nothing == explLang expl]
+--                   else decMean decl
+  explForObj d1 (ExplDeclaration d2) = d1 == d2 
+  explForObj _ _ = False
+  explanations _ = []
+--  autoMeaning lang d
+--   = [Expl { explPos   = decfpos d                       -- the position in the Ampersand script of this purpose definition
+--           , explObj   = ExplDeclaration d               -- The object that is explained.
+--           , explLang  = Just lang                       -- The language of the explanation
+--           , explRefId = ""                              -- The reference of the explaination
+--           , explCont  = [Para langInlines]              -- The actual explanation
+--           } ] 
+--     where 
+--      langInlines =
+--       case lang of
+--         English 
+--              | null ([Sym,Asy]         >- multiplicities d) -> [Emph [Str (name d)]]
+--                                                              ++[Str " is a property of a "]
+--                                                              ++[Str ((unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Sym,Rfx,Trn]     >- multiplicities d) -> [Emph [Str (name d)]]
+--                                                              ++[Str " is an equivalence relation on "]
+--                                                              ++[Str ((unCap.plural English .name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Asy,Trn]         >- multiplicities d) -> [Emph [Str (name d)]]
+--                                                              ++[Str " is an ordering relation on "]
+--                                                              ++[Str ((unCap.plural English .name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,Tot,Inj,Sur] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("exactly one "++(unCap.name.target) d)]
+--                                                              ++[Str " and vice versa."]
+--              | null ([Uni,Tot,Inj    ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("exactly one "++(unCap.name.target) d)]
+--                                                              ++[Str ", but not for each "]
+--                                                              ++[Str ((unCap.name.target) d++" there must be a "++(unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,Tot,    Sur] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("exactly one "++(unCap.name.target) d)]
+--                                                              ++[Str ", but each "]
+--                                                              ++[Str ((unCap.name.target) d++" is related to one or more "++(unCap.plural English .name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,    Inj,Sur] >- multiplicities d) -> [Str ("There is exactly one "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), for which: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str (", but not for each "++(unCap.name.source) d++" there must be a "++(unCap.name.target) d++".")]
+--              | null ([    Tot,Inj,Sur] >- multiplicities d) -> [Str ("There is exactly one "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), for which: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str (", but each "++(unCap.name.source) d++" is related to one or more "++(unCap.plural English .name.target) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,Tot        ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("exactly one "++(unCap.name.target) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,    Inj    ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("at most one "++(unCap.name.target) d)]
+--                                                              ++[Str (" and each "++(unCap.name.target) d++" is related to at most one "++(unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,        Sur] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("at most one "++(unCap.name.target) d)]
+--                                                              ++[Str (", whereas each "++(unCap.name.target) d++" is related to at least one "++(unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([    Tot,Inj    ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("at least one "++(unCap.name.target) d)]
+--                                                              ++[Str (", whereas each "++(unCap.name.target) d++" is related to at most one "++(unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([    Tot,    Sur] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("at least one "++(unCap.name.target) d)]
+--                                                              ++[Str (" and each "++(unCap.name.target) d++" is related to at least one "++(unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([        Inj,Sur] >- multiplicities d) -> [Str ("There is exactly one "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), for which: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str "."]
+--              | null ([            Sur] >- multiplicities d) -> [Str ("There is at least one "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), for which: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str "."]
+--              | null ([        Inj    ] >- multiplicities d) -> [Str ("There is at most one "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") for each "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), for which: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str "."]
+--              | null ([    Tot        ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("at least one "++(unCap.name.target) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni            ] >- multiplicities d) -> applyM d [Str ("each "++(unCap.name.source) d)]
+--                                                                         [Str ("zero or one "++(unCap.name.target) d)]
+--                                                              ++[Str "."]
+--              | otherwise                                    -> [Str "The sentence: "]
+--                                                              ++[Quoted DoubleQuote 
+--                                                                  (applyM d [Math InlineMath ((var [].source) d)]
+--                                                                            [Math InlineMath ((var [source d].target) d)])
+--                                                                ]
+--                                                              ++[Str (" is meaningful (i.e. it is either true or false) for any "++(unCap.name.source) d++" ")]
+--                                                              ++[(Math InlineMath . var [] . source) d]
+--                                                              ++[Str (" and "++(unCap.name.target) d++" ")]
+--                                                              ++[(Math InlineMath . var [source d] . target) d]
+--                                                              ++[Str "."]
+--         Dutch
+--              | null ([Sym,Asy]         >- multiplicities d) -> [Emph [Str (name d)]]
+--                                                              ++[Str " is een eigenschap van een "]
+--                                                              ++[Str ((unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Sym,Rfx,Trn]     >- multiplicities d) ->[Emph [Str (name d)]]
+--                                                              ++[Str " is een equivalentierelatie tussen "]
+--                                                              ++[Str ((unCap.plural Dutch .name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Asy,Trn]         >- multiplicities d) ->[Emph [Str (name d)]]
+--                                                              ++[Str " is een ordeningsrelatie tussen "]
+--                                                              ++[Str ((unCap.plural Dutch .name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,Tot,Inj,Sur] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                              [Str ("precies één "++(unCap.name.target) d)]
+--                                                              ++[Str " en vice versa."]
+--              | null ([Uni,Tot,Inj]     >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("precies één "++(unCap.name.target) d)]
+--                                                              ++[Str ", maar niet voor elke "]
+--                                                              ++[Str ((unCap.name.target) d)]
+--                                                              ++[Str " hoeft er een "]
+--                                                              ++[Str ((unCap.name.source) d)]
+--                                                              ++[Str " te zijn."]
+--              | null ([Uni,Tot,    Sur] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("precies één "++(unCap.name.target) d)]
+--                                                              ++[Str ", maar elke "]
+----                                                            ++[Str ((unCap.name.target) d)]
+--                                                              ++[Str (" is gerelateerd aan één of meer ")]
+--                                                              ++[Str ((unCap.plural Dutch .name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,    Inj,Sur] >- multiplicities d) -> [Str ("Er is precies één "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), waarvoor geldt: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str (", maar niet voor elke "++(unCap.name.source) d++" hoeft er een "++(unCap.name.target) d++" te zijn.")]
+--              | null ([    Tot,Inj,Sur] >- multiplicities d) -> [Str ("Er is precies één "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), waarvoor geldt: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str (", maar elke "++(unCap.name.source) d++" mag gerelateerd zijn aan meerdere "++(unCap.plural Dutch .name.target) d++".")]
+--              | null ([Uni,Tot        ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("precies één "++(unCap.name.target) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni,    Inj    ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("ten hoogste één "++(unCap.name.target) d)]
+--                                                              ++[Str " en elke "]
+--                                                              ++[Str ((unCap.name.target) d)]
+--                                                              ++[Str (" is gerelateerd aan ten hoogste één ")]
+--                                                              ++[Str ((unCap.name.source) d++".")]
+--                                                              ++[Str "."]
+--              | null ([Uni,        Sur] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("ten hoogste één "++(unCap.name.target) d)]
+--                                                              ++[Str ", terwijl elke "]
+--                                                              ++[Str ((unCap.name.target) d)]
+--                                                              ++[Str (" is gerelateerd aan tenminste één ")]
+--                                                              ++[Str ((unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([    Tot,Inj    ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("tenminste één "++(unCap.name.target) d)]
+--                                                              ++[Str ", terwijl elke "]
+--                                                              ++[Str ((unCap.name.target) d)]
+--                                                              ++[Str (" is gerelateerd aan ten hoogste één ")]
+--                                                              ++[Str ((unCap.name.source) d)]
+--                                                              ++[Str "."]
+--              | null ([    Tot,    Sur] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("tenminste één "++(unCap.name.target) d)]
+--                                                              ++[Str (" en elke "++(unCap.name.target) d++" is gerelateerd aan tenminste één "++(unCap.name.source) d++".")]
+--              | null ([        Inj,Sur] >- multiplicities d) -> [Str ("Er is precies één "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), waarvoor geldt: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str "."]
+--              | null ([            Sur] >- multiplicities d) -> [Str ("Er is tenminste één "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), waarvoor geldt: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str "."]
+--              | null ([        Inj    ] >- multiplicities d) -> [Str ("Er is hooguit één "++(unCap.name.source) d++" (")]
+--                                                              ++[Math InlineMath "a"]
+--                                                              ++[Str (") voor elke "++(unCap.name.target) d++" (")]
+--                                                              ++[Math InlineMath "b"]
+--                                                              ++[Str "), waarvoor geldt: "]
+--                                                              ++applyM d [Math InlineMath "b"] [Math InlineMath "a"]
+--                                                              ++[Str "."]
+--              | null ([    Tot        ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("tenminste één "++(unCap.name.target) d)]
+--                                                              ++[Str "."]
+--              | null ([Uni            ] >- multiplicities d) -> applyM d [Str ("elke "++(unCap.name.source) d)]
+--                                                                         [Str ("nul of één "++(unCap.name.target) d)]
+--                                                              ++[Str "."]
+--              | otherwise                                    -> [Str "De zin: "]
+--                                                              ++[Quoted DoubleQuote 
+--                                                                  (applyM d [(Math InlineMath . var [] . source) d]
+--                                                                            [(Math InlineMath . var [source d] . target) d])
+--                                                                ]
+--                                                              ++[Str (" heeft betekenis (dus: is waar of niet waar) voor een "++(unCap.name.source) d++" ")]
+--                                                              ++[(Math InlineMath . var [].source) d]
+--                                                              ++[Str (" en een "++(unCap.name.target) d++" ")]
+--                                                              ++[(Math InlineMath . var [source d].target) d]
+--                                                              ++[Str "."]
+--
+--      applyM :: Declaration -> [Inline] -> [Inline] -> [Inline]
+--      applyM decl a b =
+--               case decl of
+--                 Sgn{} | null (prL++prM++prR) 
+--                            -> a++[Space,Str "corresponds",Space,Str "to",Space]++b++[Space,Str "in",Space,Str "relation",Space,Str(decnm decl)]
+--                       | null prL
+--                            -> a++[Space,Str prM,Space]++b++[Space,Str prR]
+--                       | otherwise 
+--                            -> [Str (upCap prL),Space]++a++[Space,Str prM,Space]++b++if null prR then [] else [Space,Str prR]
+--                              where prL = decprL decl
+--                                    prM = decprM decl
+--                                    prR = decprR decl
+--                 Isn{}     -> a++[Space,Str "equals",Space]++b
+--                 Vs{}      -> [Str (show True)]
+--            
+--      var :: Identified a => [a] -> a -> String     -- TODO Vervangen door mkvar, uit predLogic.hs
+--      var seen c = low c ++ ['\'' | c'<-seen, low c == low c']
+--                      where low idt= if null (name idt) then "x" else [(toLower.head.name) idt]
+
+instance Motivated Rule where
+--  meaning l rule
+--   = head (expls++map explCont (autoMeaning l rule))
+--     where
+--        expls = [econt | Means l' econt<-rrxpl rule, l'==Just l || l'==Nothing]
+  explForObj x (ExplRule str) = name x == str
+  explForObj _ _ = False
+  explanations _ = []
+--  autoMeaning lang r
+--   = [Expl { explObj   = ExplRule (name r)                                -- The object that is explained.
+--           , explPos   = origin r
+--           , explLang  = Just lang                                        -- The language of the explaination
+--           , explRefId = ""                                               -- The reference of the explaination
+--           , explCont  = [Plain [RawInline (Text.Pandoc.Builder.Format "latex") (showPredLogic lang r++".")]] -- The actual explanation.
+--           } ] 
+
+instance Motivated Theme where
+  explForObj (PatternTheme pat) eo = explForObj pat eo
+  explForObj (ProcessTheme prc) eo = explForObj prc eo
+  explanations (PatternTheme pat) = explanations pat
+  explanations (ProcessTheme prc) = explanations prc
+  
+instance Motivated Pattern where
+--  meaning _ pat = fatal 324 ("Patterns have no intrinsic meaning, (used with pattern '"++name pat++"')")
+  explForObj x (ExplPattern str) = name x == str
+  explForObj _ _ = False
+  explanations = ptxps
+
+instance Motivated Process where
+--  meaning _ prc = fatal 329 ("Processes have no intrinsic meaning, (used with process '"++name prc++"')")
+  explForObj x (ExplProcess str) = name x == str
+  explForObj _ _ = False
+  explanations = prcXps
+
+instance Motivated Interface where
+--  meaning _ obj = fatal 342 ("Interfaces have no intrinsic meaning, (used with interface '"++name obj++"')")
+  explForObj x (ExplInterface str) = name x == str
+  explForObj _ _ = False
+  explanations _ = []
+
+class Meaning a where 
+  meaning :: Lang -> a -> Maybe A_Markup
+  meaning2Blocks :: Lang -> a -> [Block]
+  meaning2Blocks l a = case meaning l a of
+                         Nothing -> []
+                         Just m  -> amPandoc m 
+  
+instance Meaning Rule where
+  meaning l r = case filter isLang (ameaMrk (rrmean r)) of
+                  []   -> Nothing 
+                  [m]  -> Just m
+                  _    -> fatal 381 ("Too many meanings given for rule "++name r ++".")
+                  where isLang m = l == amLang m
+  
+instance Meaning Declaration where
+  meaning l d = case filter isLang (ameaMrk (decMean d)) of
+                  []   -> Nothing 
+                  [m]  -> Just m
+                  _    -> fatal 388 ("Too many meanings given for declaration "++name d ++".")
+                  where isLang m = l == amLang m
+   
+instance Motivated Fspc where
+--  meaning _ fSpec = fatal 329 ("No Fspc has an intrinsic meaning, (used with Fspc '"++name fSpec++"')")
+  explForObj x (ExplContext str) = name x == str
+  explForObj _ _ = False
+  explanations fSpec
+    = fSexpls fSpec ++
+      (concatMap explanations . vpatterns)  fSpec ++
+      (concatMap explanations . vprocesses) fSpec ++
+      (concatMap explanations . interfaceS) fSpec
+
+instance Motivated FProcess where
+--  meaning l fp = meaning l (proc fp)
+  explForObj fp = explForObj (fpProc fp)
+  explanations fp = explanations (fpProc fp)
+
+-- Ampersand allows multiple purposes for everything.
+-- The diagnosis report must make mention of this (so the user will notice if (s)he reads the diagnosis).
+-- Multiple purposes are simply concatenated, so the user sees them all.
+instance Motivated Activity where
+  explForObj _ _ = False
+  explanations activity = actPurp activity
+  purposeOf _ l x = case [ e | e <- actPurp x, amLang (explMarkup e) == l ] of
+                    []    -> Nothing
+                    purps -> Just purps
+
+
+
+ src/lib/DatabaseDesign/Ampersand/Fspec/Plug.hs view
@@ -0,0 +1,489 @@+{-# OPTIONS_GHC -Wall #-}+-- SJC: is it possible to move this to the prototype part of ampersand? I mean,+--      do functions like plugFields and plug-path really need to be here?+--      perhaps we can at least move the largest part?+module DatabaseDesign.Ampersand.Fspec.Plug+     (Plugable(..), PlugInfo(..)+     ,SqlField(..)+     ,SqlFieldUsage(..)+     ,SqlType(..)+     ,showSQL+     ,requiredFields,requires,plugpath,eLkpTbl+     ,plugFields+     ,tblcontents+--     ,entityfield+     ,fldauto+     ,isPlugIndex,kernelrels,attrels,bijectivefields+     ,PlugSQL(..)+     )+where+import DatabaseDesign.Ampersand.ADL1 +import DatabaseDesign.Ampersand.Classes (Object(..),Populated(..),atomsOf,ConceptStructure(..),Relational(..))+import DatabaseDesign.Ampersand.Basics+import Data.List(elemIndex,nub,intercalate,sort)+import GHC.Exts (sortWith)+import DatabaseDesign.Ampersand.Fspec.Fspec+import DatabaseDesign.Ampersand.Fspec.FPA (FPAble(fpa))+import Prelude hiding (Ordering(..),head)++-- import Debug.Trace  +-- Dummy trace function.+trace :: String -> a -> a  +trace _ a = a++head :: [a] -> a+head [] = fatal 30 "head must not be used on an empty list!"+head (a:_) = a+++fatal :: Int -> String -> a+fatal = fatalMsg "Fspec.Plug"++----------------------------------------------+--Plug+----------------------------------------------+--TODO151210 -> define what a plug is and what it should do+--Plugs are of the class Object just like Activities(??? => PHP plug isn't an instance of Object)+--An Object is an entity to do things with like reading, updating, creating,deleting.+--A Interface is an Object using only Plugs for reading and writing data; a Plug is a data service maintaining the rules for one object:+-- + GEN Interface,Plug ISA Object+-- + cando::Operation*Object+-- + uses::Interface*Plug [TOT].+-- + maintains::Plug*Rule.+-- + signals::Interface*SignalRule.+--+--Plugs can currently be implemented in PHP or SQL.+--type Plugs = [Plug]+--data Plug = PlugSql PlugSQL | PlugPhp PlugPHP deriving (Show,Eq)++class (Identified p, Eq p, Show p) => Plugable p where+  makePlug :: PlugInfo -> p+  +instance Plugable PlugSQL where+  makePlug (InternalPlug p) = p+  makePlug (ExternalPlug _) = fatal 112 "external plug is not Plugable"+ +instance FPAble PlugInfo where+  fpa (InternalPlug _) = fatal 55 "FPA analysis of internal plugs is currently not supported"+  fpa (ExternalPlug _)  = fatal 56 "FPA analysis of external plugs is currently not supported"++instance ConceptStructure PlugInfo where+  concs   (InternalPlug psql) = concs   psql+  concs   (ExternalPlug obj)  = concs   obj+  expressionsIn (InternalPlug psql) = expressionsIn psql+  expressionsIn (ExternalPlug obj)  = expressionsIn obj+   +++----------------------------------------------+--PlugSQL+----------------------------------------------+--TblSQL, BinSQL, and ScalarSQL hold different entities. See their definition Fspec.hs++--           all kernel fields can be related to an imaginary concept ID for the plug (a SqlField with type=SQLID)+--             i.e. For all kernel fields k1,k2, where concept k1=A, concept k2=B, fldexpr k1=r~, fldexpr k2=s~+--                  You can imagine :+--                    - a relation value::ID->A[INJ] or value::ID->A[INJ,SUR]+--                    - a relation value::ID->B[INJ] or value::ID->B[INJ,SUR]+--                    such that s~=value~;value;r~ and r~=value~;value;s~+--                    because value is at least uni,tot,inj, all NULL in k0 imply NULL in k1 xor v.v.+--                    if value also sur then all NULL in k0 imply NULL in k1 and v.v.+--           Without such an ID, the surjective or total property between any two kernel fields is required.+--           Because you can imagine an ID concept the surjective or total property between two kernel field has become a design choice.+--+--           With or without ID we choose to keep kernel = A closure of concepts A,B for which there exists a r::A->B[INJ] instead of r::A*B[UNI,INJ]+--           By making this choice:+--             - nice database table size+--             - we do not need the imaginary concept ID  (and relation value::ID->A[INJ] or value::ID->A[INJ,SUR]), because:+--                  with ID    -> there will always be one or more kernel field k1 such that (value;(fldexpr k1)~)[UNI,INJ,TOT,SUR].+--                                any of those k1 can serve as ID of the plug (a.k.a. concept p / source p)+--                  without ID -> any of those k1 can still serve as ID of the plug (a.k.a. concept p / source p)+--               In other words, the imaginary concept is never needed +--                               because there always is an existing one with the correct properties by definition of kernel.+--               Implementation without optional ID:+--                        -> fldexpr of some kernel field k1 will be r~+--                           k1 holds the target of r~+--                           the source of r~ is a kernel concept too+--                           r~ may be I+--                        -> fldexpr of some attMor field a1 will be s+--                           a1 holds the target of s+--                           the source of s is a kernel concept+--                        -> sqlRelFields r = (r,k1,a1) (or (r,k1,k2)) in mLkpTbl+--                           is used to generate SQL code and PHP-objects without needing the ID field.+--                           The ID field can be ignored and does not have to be generated because r=(fldexpr k1)~;(fldexpr a1)+--                           You could generate the ID-field with autonum if you want, because it will not be used+--                        -> TODO151210 -> sqlRelFields e where e is not in mLkpTbl+--                           option1) Generate the ID field (see entityfield)+--                                    sqlRelFields e = (e, idfld;k1, idfld;a1) where e=(fldexpr k1)~;value~;value;(fldexpr a1)+--                                    remark: binary tables can be binary tables without kernels, but with ID field+--                                            (or from a different perspective: ID is the only kernel field)+--                                            sqlRelFields r = (r,idfld/\r;r~,idfld;m1) where r = (idfld/\r;r~)~;idfld;(fldexpr m1)+--                                            (sqlRelFields r~  to get the target of r)+--                                            (scalar tables can of course also have an ID field)+--                           option2) sqlRelFields e = (e, k1;k2;..kn, a1) +--                                    where e=(fldexpr kn)~;..;(fldexpr k2)~;(fldexpr k1)~;(fldexpr k1)(fldexpr k2);..;(fldexpr kn);(fldexpr a1)+--                           If I am right the function isTrue tries to support sqlRelFields e by ignoring the type error in kn;a1.+--                           That is wrong! ++--the entityfield is not implemented as part of the data type PlugSQL+--It is a constant which may or may not be used (you may always imagine it)+--TODO151210 -> generate the entityfield if options = --autoid -p+--REMARK151210 -> one would expect I[entityconcept p], +--                but any p (as instance of Object) has one always existing concept p suitable to replace entityconcept p.+--                concept p and entityconcept p are related uni,tot,inj,sur.+--data SqlFieldUsage = PrimKey A_Concept     -- The field is the primary key of the table+--                   | ForeignKey A_Concept  -- The field is a reference (containing the primary key value of) a TblSQL+--                   | PlainAttr             -- None of the above+--                   | NonMainKey            -- Key value of an Specialization of the Primary key. (field could be null)+--                   | UserDefinedUsage+--                   | FillInLater          -- Must be filled in later....+entityfield :: PlugSQL -> SqlField+entityfield p+  = Fld { fldname = name (entityconcept p)+        , fldexpr = EDcI (concept p)+        , fldtype = SQLId+        , flduse  = PrimKey (concept p)  -- SJ 4 nov 2013:  TODO: is this correct?? (this field may have been subject to bit rot...+        , fldnull = False+        , flduniq = True+        }+--the entity stored in a plug is an imaginary concept, that is uni,tot,inj,sur with (concept p)+--REMARK: there is a (concept p) because all kernel fields are related SUR with (concept p)+entityconcept :: PlugSQL -> A_Concept+entityconcept BinSQL{} --create the entityconcept of the plug, and an instance of ID for each instance of mLkp+  = PlainConcept+      { cptnm = "ID"+      , cpttp = []+      , cptdf = []+      }+entityconcept p --copy (concept p) to create the entityconcept of the plug, using instances of (concept p) as instances of ID+  = case concept p of+     PlainConcept{} -> (concept p){cptnm=name(concept p)++ "ID"} +     _   ->  fatal 225 $ "entityconcept error in PlugSQL: "++name p++"."++++++--Maintain rule: Object ObjectDef = Object (makeUserDefinedSqlPlug :: ObjectDef -> PlugSQL)+--TODO151210 -> Build a check which checks this rule for userdefined/showADL generated plugs(::[ObjectDef]) +--TODO151210 -> The ObjectDef of a BinSQL plug for relation r is that:+--           1) SQLPLUG mybinplug: r      , or+--           2) SQLPLUG labelforsourcem : I /\ r;r~ --(or just I if r is TOT)+--               = [labelfortargetm : r]+--           The first option has been implemented in instance ObjectPlugSQL i.e. attributes=[], ctx=ERel r _+instance Object PlugSQL where+ concept p = case p of+   TblSQL{mLkpTbl = []} -> fatal 263 $ "empty lookup table for plug "++name p++"."+   TblSQL{}             -> --TODO151210-> deze functieimplementatie zou beter moeten matchen met onderstaande beschrijving+                            --        nu wordt aangenomen dat de source van het 1e rel in mLkpTbl de source van de plug is.+                            --a relation between kernel concepts r::A*B is at least [UNI,INJ]+                            --to be able to point out one concept to be the source we are looking for one without NULLs in its field+                            -- i.e. there is a concept A such that+                            --      for all kernel field expr (s~)::B*C[UNI,INJ]:+                            --      s~ is total and there exists an expr::A*B[UNI,INJ,TOT,SUR] (possibly A=B => I[A][UNI,INJ,TOT,SUR]) +                            --If A is such a concept,+                            --   and A is not B,+                            --   and there exist an expr::A*B[UNI,INJ,TOT,SUR]+                            --then (concept PlugSQL{}) may be A or B+                            --REMARK -> (source p) used to be implemented as (source . fldexpr . head . fields) p. That is different!+                            head [source r |(r,_,_)<-mLkpTbl p]+   BinSQL{} -> source (mLkp p) --REMARK151210 -> the concept is actually ID such that I[ID]=I[source r]/\r;r~+   ScalarSQL{} -> cLkp p+-- Usually source a==concept p. Otherwise, the attribute computation is somewhat more complicated. See ADL2Fspec for explanation about kernels.+ attributes p@TblSQL{}+  = [ Obj (fldname tFld)                                                   -- objnm +          (Origin "This object is generated by attributes (Object PlugSQL)")                        -- objpos+          (if source a==concept p then a  else f (source a) [[a]])  -- objctx+          Nothing []                                                            -- objats and objstrs+    | (a,_,tFld)<-mLkpTbl p]+    where+     f c mms+      = case sortWith length stop of+         []  -> f c mms'  -- a path from c to a is not found (yet), so add another step to the recursion+         (hd:_) -> case hd of+                    []  -> fatal 201 "Empty head should be impossible."+                    _  -> case [(l,r) | (l,r)<-zip (init hd) (tail hd), target l/=source r] of+                            [] -> foldr1 (.:.) hd  -- pick the shortest path and turn it into an expression.+                            lrs -> fatal 204 ("illegal compositions " ++show lrs)+      where+        mms' = if [] `elem` mms +               then fatal 295 "null in mms."+               else [a:ms | ms<-mms, (a,_,_)<-mLkpTbl p, target a==source (head ms)]+        stop = if [] `elem` mms'+               then fatal 298 "null in mms'."+               else [ms | ms<-mms', source (head ms)==c]  -- contains all found paths from c to a + attributes _ = [] --no attributes for BinSQL and ScalarSQL+ contextOf p@BinSQL{} = mLkp p + contextOf p = EDcI (concept p)+++fldauto::SqlField->Bool -- is the field auto increment?+fldauto f = (fldtype f==SQLId) && not (fldnull f) && flduniq f -- && isIdent (fldexpr f)+++showSQL :: SqlType -> String+showSQL (SQLChar    n) = "CHAR("++show n++")"+showSQL (SQLBlob     ) = "BLOB"+showSQL (SQLPass     ) = "VARCHAR(255)"+showSQL (SQLSingle   ) = "FLOAT" -- todo+showSQL (SQLDouble   ) = "FLOAT"+showSQL (SQLText     ) = "TEXT"+showSQL (SQLuInt    n) = "INT("++show n++") UNSIGNED"+showSQL (SQLsInt    n) = "INT("++show n++")"+showSQL (SQLId       ) = "INT"+showSQL (SQLVarchar n) = "VARCHAR("++show n++")"+showSQL (SQLBool     ) = "BOOLEAN"+          +-- Every kernel field is a key, kernel fields are in cLkpTbl or the column of ScalarSQL (which has one column only)+-- isPlugIndex refers to UNIQUE key -- TODO: this is wrong+--isPlugIndex may contain NULL, but their key (the entityfield of the plug) must be unique for a kernel field (isPlugIndex=True)+--the field that is isIdent and isPlugIndex (i.e. concept plug), or any similar (uni,inj,sur,tot) field is also UNIQUE key+--IdentityDefs define UNIQUE key (fld1,fld2,..,fldn)+--REMARK -> a kernel field does not have to be in cLkpTbl, in that cast there is another kernel field that is +--          thus I must check whether fldexpr isUni && isInj && isSur+isPlugIndex :: PlugSQL->SqlField->Bool+isPlugIndex plug f =+  case plug of +    ScalarSQL{} -> sqlColumn plug==f+    BinSQL{}  --mLkp is not uni or inj by definition of BinSQL, if mLkp total then the (fldexpr srcfld)=I/\r;r~=I i.e. a key for this plug+     | isUni(mLkp plug) || isInj(mLkp plug) -> fatal 366 "BinSQL may not store a univalent or injective rel, use TblSQL instead."+     | otherwise                            -> False --binary does not have key, but I could do a SELECT DISTINCT iff f==fst(columns plug) && (isTot(mLkp plug)) +    TblSQL{}    -> elem f (fields plug) && isUni(fldexpr f) && isInj(fldexpr f) && isSur(fldexpr f)++--mLkpTbl stores the relation of some target field with one source field+--an isPlugIndex target field is a kernel field related to some similar or larger kernel field+--any other target field is an attribute field related to its kernel field+kernelrels::PlugSQL ->[(SqlField,SqlField)]+kernelrels plug@ScalarSQL{} = [(sqlColumn plug,sqlColumn plug)]+kernelrels (BinSQL{})       = fatal 375 "Binary plugs do not know the concept of kernel fields."+kernelrels plug@TblSQL{}    = [(sfld,tfld) |(_,sfld,tfld)<-mLkpTbl plug,isPlugIndex plug tfld] +attrels::PlugSQL ->[(SqlField,SqlField)]+attrels plug@ScalarSQL{}    = [(sqlColumn plug,sqlColumn plug)]+attrels BinSQL{}            = fatal 379 "Binary plugs do not know the concept of attribute fields."+attrels plug@TblSQL{}       = [(sfld,tfld) |(_,sfld,tfld)<-mLkpTbl plug,not(isPlugIndex plug tfld)] ++++--the kernel of SqlFields is ordered by existence of elements for some instance of the entity stored in the plug.+--fldexpr of key is the relation with a similar or larger key.+--(similar = uni,tot,inj,sur, includes = uni,inj,sur)+--+--each kernel field is a key to attributes and itself (kfld), and each attribute field is related to one kernel field (kfld)+--kfld may be smaller than the ID of the plug, but larger than other kernel fields in the plug+--All (kernel) fields larger than or similar to kfld and their total attributes are required.+--(remark that the total property of an attribute points to the relation of the att with its key, which is not the ID of the plug per se)+--Smaller (kernel) fields and their total attributes may contain NULL where kfld does not and are not required.+--+--auto increment fields are not considered to be required+requiredFields :: PlugSQL -> SqlField ->[SqlField]+requiredFields plug@ScalarSQL{} _ = [sqlColumn plug]+requiredFields plug@BinSQL{}    _ = [fst(columns plug),snd(columns plug)]+requiredFields plug@TblSQL{} fld + = [f |f<-requiredkeys++requiredatts, not (fldauto f)] +  where+  kfld | null findfld = fatal 401 $ "fld "++fldname fld++" must be in the plug "++name plug++"."+       | isPlugIndex plug fld = fld+       | otherwise = fst(head findfld) --fld is an attribute field, take its kernel field+  findfld = [(k,maybek) |(_,k,maybek)<-mLkpTbl plug,fld==maybek]+  requiredkeys = similar++requiredup +  requiredatts = [a |k<-requiredkeys,(k',a)<-attrels plug,k==k',isTot(fldexpr a)]+  -----------+  --kernelclusters is a list of kernel field clusters clustered by similarity+  --similar is the cluster where kfld is in+  similar = [c |Cluster cs<-kernelclusters plug,kfld `elem` cs,c<-cs]+  --the kernel fields in which a similar field is included, but not a similar field+  --(clusterBy includeskey [Cluster [x]] (kernelrels plug) returns one inclusion chain (cluster) from ID to x +  --Thus, similar elements of elements in the chain (except x) are not taken into account yet (see similarskeysup and requiredup)+  keysup = nub[rf |x<-similar+                  ,cs<-map cslist(clusterBy includeskey [Cluster [x]] (kernelrels plug))+                  ,rf<-cs]+            >- similar+  --there can be a key1 similar to a key2 in keysup, but key1 is not in keysup.+  --key1 is required just like key2 because they are similar+  similarskeysup = nub[key1 | Cluster cs<-kernelclusters plug+                            , key1<-cs +                            , key2<-keysup+                            , key2 `elem` cs+                            , key1 `notElem` keysup]+  --the similarskeysup may have required fields not in keysup (recursion)+  --add those which are not in keysup yet+  requiredup = nub(keysup++requiredbysimilarkeysup)+  requiredbysimilarkeysup = nub[rf |x<-similarskeysup,rf<-requiredFields plug x]+  -----------++--fld1 requires fld2 in plug?+requires :: PlugSQL -> (SqlField,SqlField) ->Bool+requires plug (fld1,fld2) = fld2 `elem` requiredFields plug fld1++composeCheck :: Expression -> Expression -> Expression+composeCheck l r+ = if target l/=source r then fatal 316 ("\nl: "++show l++"with target "++show (target l)++"\nl: "++show r++"with source "++show (source r)) else+   l .:. r+ +--composition from srcfld to trgfld, if there is an expression for that+plugpath :: PlugSQL -> SqlField -> SqlField -> Maybe Expression+plugpath p srcfld trgfld =+ case p of+  BinSQL{}+   | srcfld==trgfld -> let tm=mLkp p --(note: mLkp p is the relation from fst to snd column of BinSQL)+                       in if srcfld==fst(columns p) +                          then Just$ tm .:. flp tm --domain of r+                          else Just$ flp tm .:. tm --codomain of r+   | srcfld==fst(columns p) && trgfld==snd(columns p) -> Just$ fldexpr trgfld+   | trgfld==fst(columns p) && srcfld==snd(columns p) -> Just$ flp(fldexpr srcfld)+   | otherwise -> fatal 444 $ "BinSQL has only two fields:"++show(fldname srcfld,fldname trgfld,name p)+  ScalarSQL{}+   | srcfld==trgfld -> Just$ fldexpr trgfld+   | otherwise -> fatal 447 $ "scalarSQL has only one field:"++show(fldname srcfld,fldname trgfld,name p)+  TblSQL{}  +   | srcfld==trgfld && isPlugIndex p trgfld -> Just$ EDcI (target (fldexpr trgfld))+   | srcfld==trgfld && not(isPlugIndex p trgfld) -> Just$ composeCheck (flp (fldexpr srcfld)) (fldexpr trgfld) --codomain of r of morAtt+   | (not . null) (paths srcfld trgfld)+      -> case head (paths srcfld trgfld) of+          []    -> fatal 338 ("Empty head (paths srcfld trgfld) should be impossible.")+          ps    -> Just$ foldr1 composeCheck ps+   --bijective kernel fields, which are bijective with ID of plug have fldexpr=I[X].+   --thus, path closures of these kernel fields are disjoint (path closure=set of fields reachable by paths),+   --      because these kernel fields connect to themselves by r=I[X] (i.e. end of path).+   --connect two paths over I[X] (I[X];srce)~;(I[X];trge) => filter I[X] => srcpath~;trgpath+   | (not.null) (pathsoverIs srcfld trgfld) -> Just$      foldr1 composeCheck (head (pathsoverIs srcfld trgfld))+   | (not.null) (pathsoverIs trgfld srcfld) -> Just$ flp (foldr1 composeCheck (head (pathsoverIs trgfld srcfld)))+   | otherwise -> Nothing+  --paths from s to t by connecting r from mLkpTbl+  --the (r,srcfld,trgfld) from mLkpTbl form paths longer paths if connected: (trgfld m1==srcfld m2) => (m1;m2,srcfld m1,trgfld m2)+  where+  paths s t = [e |(e,es,et)<-eLkpTbl p,s==es,t==et]+  --paths from I to field t+  pathsfromIs t = [(e,es,et) |(e,es,et)<-eLkpTbl p,et==t,not (null e),isIdent(head e)] +  --paths from s to t over I[X]+  pathsoverIs s t = [flpsrce++tail trge +                    |(srce,srces,_)<-pathsfromIs s+                    ,(trge,trges,_)<-pathsfromIs t+                    ,srces==trges, let flpsrce = (map flp.reverse.tail) srce] ++--the expression LkpTbl of a plug is the transitive closure of the mLkpTbl of the plug+--Warshall's transitive closure algorithm clos1 :: (Eq a) => [(a,a)] -> [(a,a)] is extended to combine paths i.e. r++r'+--[Expression] implies a 'composition' from a kernel SqlField to another SqlField+--use plugpath to get the Expression from srcfld to trgfld+--plugpath also combines expressions with head I like (I;tail1)~;(I;tail2) <=> tail1;tail2+eLkpTbl::PlugSQL -> [([Expression],SqlField,SqlField)]+eLkpTbl p = clos1 [([r],s,t)|(r,s,t)<-mLkpTbl p]+  where+  clos1 :: [([Expression],SqlField,SqlField)] -> [([Expression],SqlField,SqlField)]     -- e.g. a list of SqlField pairs+  clos1 xs+     = foldl f xs (nub (map (\(_,x,_)->x) xs) `isc` nub (map (\(_,_,x)->x) xs))+       where+        f q x = q `uni` [( r++r' , a, b') | (r ,a, b) <- q, b == x, (r', a', b') <- q, a' == x]++--bijective fields of f (incl. f)+bijectivefields::PlugSQL -> SqlField -> [SqlField]+bijectivefields p f = [bij |Cluster fs<-kernelclusters p, f `elem` fs,bij<-fs]++--the clusters of kernel sqlfields that are similar because they relate uni,inj,tot,sur+kernelclusters ::PlugSQL -> [Cluster SqlField]+kernelclusters plug@ScalarSQL{} = [Cluster [sqlColumn plug]]+kernelclusters (BinSQL{})       = [] --a binary plugs has no kernel (or at most (entityfield plug))+kernelclusters plug@TblSQL{}    = clusterBy similarkey [] (kernelrels plug)++--similar key: some source key s that is not equal to target key t (i.e. not the identity), but related uni,tot,inj,sur in some other way+similarkey::(SqlField,SqlField)->Bool+similarkey (s,t) = s/=t && isTot (fldexpr t) && isSur (fldexpr t) && isInj (fldexpr t) && isUni (fldexpr t)++--includes key: some target key t that is related to source key s uni,inj,sur but not tot+includeskey::(SqlField,SqlField)->Bool+includeskey (_,t) = not(isTot (fldexpr t)) && isSur (fldexpr t) && isInj (fldexpr t) && isUni (fldexpr t)++--clusterBy clusters similar items like eqClass clusters equal items+--[(a,a)] defines flat relations between items (not closed)+--((a,a) -> Bool) defines some transitive relation between two items (for example similarity, equality, inclusion)+--[Cluster a] defines the initial set of clusters which may be [] +--            EXAMPLE USE -> +--            if the relation is not symmetric and you need one chain from x to the top+--            then set [Cluster [x]]+--            (note: ClusterBy does not take into account any other relation than the one provided!)+--TODO -> test plugs that require more than one run (i.e. a composition of kernel fields n>2: ID(fld1;fld2;..;fldn)KernelConcept )+--REMARK151210 -> I have made a data type of cluster instead of just list to distinguish between lists and clusters (type checked and better readable code)+--                It is an idea to do the same for eqCl and eqClass (Class=Cluster or v.v.)+data Cluster a = Cluster [a] deriving (Eq,Show)+cslist :: Cluster a -> [a]+cslist (Cluster xs) = xs+clusterBy :: (Show a,Eq a) => ((a,a) -> Bool) -> [Cluster a] -> [(a,a)] -> [Cluster a]+clusterBy f [] xs = clusterBy f [Cluster [b] |(_,b)<-xs] xs --initial clusters, for every target there will be a cluster at first (see mergeclusters)+clusterBy f cs xs  +   | cs==nxtrun = mergeclusters cs +   | otherwise = clusterBy f (mergeclusters nxtrun) xs+   where +   nxtrun = [Cluster (addtohead (head ys)++ys) |Cluster ys<-cs, not(null ys)]+   addtohead y =[fst x | x<-xs, snd x==y, f x] --if x=(fst x);y and (f x), then fst x is chained to y +   --we can merge clusters with equal heads, because+   -- + similar things are chained to the head of the cluster+   -- + and the head of mergeclusters == head of every cluster in cs' because we mergecluster each time we add one thing to the head of some cluster+   mergeclusters cs' = [Cluster (nub(concat cl)) |cl<-eqClass eqhead (map cslist cs')] +   eqhead c1 c2 +     | null (c1++c2) = fatal 547 "clusters are not expected to be empty at this point."+     | otherwise = head c1==head c2++--TODO151210 -> revise ConceptStructure SqlField & PlugSQL+--   concs f = [target e' |let e'=fldexpr f,isSur e']+--   concs p = concs     (fields p)+--   this implies that concs of p are only the targets of kernel fields i.e. kernel concepts  +--   class ConceptStructure describes concs as "the set of all concepts used in data structure a"+--   The question arises (and should be answered in this comment and implemented)+--      WHAT IS THE DATA STRUCTURE PlugSQL?+--I expect that instance ConceptStructure SqlField is only used for instance ConceptStructure PlugSQL as its implementation +--is tailored to the needs of PlugSQL as a data structure, not SqlField as a Data structure!+--For convenience, I implemented localfunction, which should be removed at revision+instance ConceptStructure SqlField where+  concs     f = [target e' |let e'=fldexpr f,isSur e']+  expressionsIn   f = expressionsIn   (fldexpr f)+  mp1Exprs = fatal 452 "mp1Exprs is not meant to be for a plug."++instance ConceptStructure PlugSQL where+  concs     p = concs   (plugFields p)+  expressionsIn   p = expressionsIn (plugFields p)+  mp1Exprs = fatal 458 "mp1Exprs is not meant to be for a plug."++plugFields::PlugSQL->[SqlField]+plugFields plug = case plug of+    TblSQL{}    -> fields plug+    BinSQL{}    -> [fst(columns plug),snd(columns plug)]+    ScalarSQL{} -> [sqlColumn plug]++type TblRecord = [String]+tblcontents :: [A_Gen] -> [Population] -> PlugSQL -> [TblRecord]+tblcontents gens udp plug@ScalarSQL{}+   = [[x] | x<-atomsOf gens udp (cLkp plug)]+tblcontents gens udp plug@BinSQL{}+   = [[x,y] |(x,y)<-fullContents gens udp (mLkp plug)]+tblcontents gens udp plug@TblSQL{}+ --TODO151210 -> remove the assumptions (see comment data PlugSQL)+ --fields are assumed to be in the order kernel+other, + --where NULL in a kernel field implies NULL in the following kernel fields+ --and the first field is unique and not null+ --(r,s,t)<-mLkpTbl: s is assumed to be in the kernel, fldexpr t is expected to hold r or (flp r), s and t are assumed to be different+ | null(fields plug) = fatal 593 "no fields in plug."+ | flduniq idfld && not(fldnull idfld) && isIdent (fldexpr idfld)+   = let +     pos fld = case elemIndex fld (fields plug) of +       Just n  -> n+1+       Nothing -> fatal 598 "field is expected."+     rels fld = [ ((pos s,pos t),xy) | (_,s,t)<-mLkpTbl plug+                , s /= t +                , fld==s+                , xy<-fullContents gens udp (fldexpr t)+                ]+     in --add relation values to the record, from left to right field (concat=rels with source idfld++rels with source fld2++..) +     [ foldl insertrel --(a -> b -> a)+             (take (length (fields plug)) (idval:[[] |_<-[(1::Int)..]])) --new record for id+             (concatMap rels (fields plug))  +     | idval<-map fst (fullContents gens udp (fldexpr idfld))  ]+ | otherwise = fatal 609 "fields are assumed to be in the order kernel+other, starting with an id-field."+   where idfld = head (fields plug)+--if x at position n of some record, then position r is replaced by y (position starts at 1, not 0!)+insertrel::TblRecord->((Int,Int),Paire)->TblRecord+insertrel rec ((n,r),(x,y))+ | length rec < n || length rec < r +   = fatal 615 $ "cannot take position "++show n++" or "++show r++" of "++show rec++"."+ | x==(rec !! (n - 1)) --x at position n of rec+   = take (r-1) rec++y:drop r rec --position r is replaced by y+ | otherwise = rec --unchanged
+ src/lib/DatabaseDesign/Ampersand/Fspec/ShowADL.hs view
@@ -0,0 +1,548 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE FlexibleInstances #-}
+  -- The purpose of ShowADL is to print things in Ampersand source format.
+  -- Rule: The semantics of each fSpec produced by the compiler is identical to the semantics  of (parse (showADL fSpec)).
+  -- Rule: The standard show is used only for simple error messages during testing.
+  -- Question (SJC): If STRING is the code produced by showADL, would STRING == showADL (parse STRING) (context (parse STRING)) be true?
+  -- Answer (SJ):   No, not for every STRING. Yet, for every fSpec we want  semantics fSpec == semantics (parse (showADL fSpec)).
+  --                Note that 'parse' and 'semantics' do not exist in this shape, so the actual expression is slightly more complicated.
+  --
+  -- Every Expression should be disambiguated before printing to ensure unambiguity.
+module DatabaseDesign.Ampersand.Fspec.ShowADL
+    ( ShowADL(..), LanguageDependent(..))
+where
+import DatabaseDesign.Ampersand.Core.ParseTree
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+import DatabaseDesign.Ampersand.Basics      (fatalMsg,eqCl,Collection(..),Identified(..))
+import DatabaseDesign.Ampersand.Classes
+import DatabaseDesign.Ampersand.Fspec.Fspec
+import Data.List hiding (head)
+import Prelude hiding (head)
+
+head :: [a] -> a
+head [] = fatal 30 "head must not be used on an empty list!"
+head (a:_) = a
+
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Fspec.ShowADL"
+
+class ShowADL a where
+ showADL :: a -> String
+
+-- there are data types yielding language dependent data like an Expression
+-- the LanguageDependent class provides function(s) to map language dependent functions on those data if any.
+-- for example to print all expressions in a data structure with a practical amount of type directives
+-- (instances have been created when needed)
+--
+-- LanguageDependent is part of ShowAdl because the only application at time of writing is to disambiguate expressions for the purpose of printing
+-- SJ 31-12-2012: Since 'disambiguate' has become obsolete, do we still need this?
+class LanguageDependent a where
+  mapexprs :: (Language l, ConceptStructure l, Identified l) => (l -> Expression -> Expression) -> l -> a -> a
+  mapexprs _ _ = id
+
+instance LanguageDependent a => LanguageDependent (Maybe a) where
+  mapexprs _ _ Nothing  = Nothing
+  mapexprs f l (Just x) = Just $ mapexprs f l x
+
+instance LanguageDependent (a, Expression) where
+  mapexprs f l (x,e) = (x, f l e)
+instance LanguageDependent Rule where
+  mapexprs f l rul = rul{rrexp = f l (rrexp rul)}
+instance LanguageDependent Interface where
+  mapexprs f l ifc = ifc{ifcObj = mapexprs f l (ifcObj ifc)}
+instance LanguageDependent ObjectDef where
+  mapexprs f l obj = obj{objctx = f l (objctx obj), objmsub = mapexprs f l $ objmsub obj}
+instance LanguageDependent SubInterface where
+  mapexprs _ _ iref@(InterfaceRef _) = iref
+  mapexprs f l (Box o objs) = Box o $ map (mapexprs f l) objs
+instance LanguageDependent Declaration where
+  mapexprs _ _ = id
+instance LanguageDependent ECArule where
+  mapexprs _ _ = id
+instance LanguageDependent Event where
+  mapexprs _ _ = id
+--------------------------------------------------------------
+instance ShowADL (P_SubIfc a) where
+  showADL (P_Box{}) = "BOX"
+  showADL (P_InterfaceRef _ nm) = " INTERFACE "++showstr nm
+  
+
+instance ShowADL ObjectDef where
+-- WHY (HJ)? In deze instance van ShowADL worden diverse zaken gebruikt die ik hier niet zou verwachten.
+--              Het vertroebelt de code ook een beetje, want nu moeten er dingen als 'source' en
+--              'target' hier al bekend zijn.
+--              Dat lijkt me hier nog niet op z'n plaats, als je alleen maar wat wilt kunnen 'prettyprinten'. 
+-- BECAUSE (SJ): Dit blijft nog even zo, omdat showADL gebruikt wordt in het genereren van interfaces.
+--              Zolang we dat nog niet onder de knie hebben blijft de code wat troebel.
+ showADL obj = " : "++showADL (objctx obj)++
+               recur "\n  " (objmsub obj)
+  where recur :: String -> Maybe SubInterface -> String
+        recur _   Nothing = ""
+        recur ind (Just (InterfaceRef nm)) = ind++" INTERFACE "++showstr nm
+        recur ind (Just (Box _ objs))
+         = ind++" BOX [ "++
+           intercalate (ind++"     , ") 
+                               [ showstr (name o)++
+                                  (if null (objstrs o) then "" else " {"++intercalate ", " [showstr (unwords ss) | ss<-objstrs o]++"}")++
+                                  " : "++showADL (objctx o)++
+                                  recur (ind++"      ") (objmsub o)
+                               | o<-objs
+                               ]++
+           ind++"     ]"
+
+instance ShowADL Meta where
+ showADL (Meta _ metaObj nm val) = 
+   "META "++(if null $ showADL metaObj then "" else showADL metaObj++" ") ++show nm++" "++show val
+
+instance ShowADL MetaObj where
+ showADL ContextMeta = ""
+ 
+instance ShowADL Purpose where
+ showADL expl = "PURPOSE "++showADL (explObj expl)
+                ++showADL (amLang (explMarkup expl))
+                ++showADL (amFormat (explMarkup expl))
+                ++(if null (explRefId expl) then "" else " REF "++explRefId expl)
+                ++ "{+"++aMarkup2String (explMarkup expl)++"-}"
+
+instance ShowADL PandocFormat where
+ showADL LaTeX = "LATEX"
+ showADL HTML  = "HTML"
+ showADL ReST  = "REST"
+ showADL Markdown = "MARKDOWN"
+ 
+instance ShowADL A_Markup where
+ showADL m 
+     = "IN " ++showADL (amLang m) 
+    ++ " "++showADL (amFormat m) 
+    ++ "{+"++aMarkup2String m++"-}"
+    
+instance ShowADL Lang where
+ showADL Dutch   = "DUTCH"
+ showADL English = "ENGLISH"
+   
+--instance ShowADL (Maybe Lang) where
+-- showADL  Nothing       = "IN DUTCH"
+-- showADL (Just Dutch  ) = "IN DUTCH"
+-- showADL (Just English) = "IN ENGLISH"
+   
+instance ShowADL ExplObj where
+ showADL e = case e of
+      ExplConceptDef cd  -> "CONCEPT "++cdcpt cd
+      ExplDeclaration d  -> "RELATION "++show (name d)
+      ExplRule str       -> "RULE "++showstr str
+      ExplIdentityDef str-> "IDENT "++showstr str
+      ExplViewDef str    -> "VIEW "++showstr str
+      ExplPattern str    -> "PATTERN "++ showstr str
+      ExplProcess str    -> "PROCESS "++str
+      ExplInterface str  -> "INTERFACE "++showstr str
+      ExplContext str    -> "CONTEXT "++showstr str
+
+showstr :: String -> String
+showstr str = "\""++str++"\""
+
+-- The declarations of the pattern are supplemented by all declarations needed to define the rules.
+-- Thus, the resulting pattern is self-contained with respect to declarations.
+instance ShowADL Process where
+ showADL prc
+  = "PROCESS " ++ name prc 
+    ++ (if null (udefrules prc) then "" else "\n  " ++intercalate "\n  " (map showADL (udefrules prc)) ++ "\n")
+    ++ (if null (maintains prc) then "" else "\n  " ++                        showRM prc               ++ "\n")
+    ++ (if null (mayEdit prc)   then "" else "\n  " ++                        showRR prc               ++ "\n")
+    ++ (if null (conceptDefs prc)    then "" else "\n  " ++intercalate "\n  " (map showADL (conceptDefs prc))    ++ "\n")
+    ++ (if null (prcIds prc)    then "" else "\n  " ++intercalate "\n  " (map showADL (prcIds prc))    ++ "\n")
+    ++ (if null (prcXps prc)    then "" else "\n  " ++intercalate "\n  " (map showADL (prcXps prc))    ++ "\n")
+    ++ "ENDPROCESS"
+    where -- TODO: the following definitions should be unneccessary, but 'map showADL (maintains prc)' and "map showADL (mayEdit prc)" don't work... 
+      showRM :: Process -> String
+      showRM pr = intercalate "\n  " [ "ROLE "++role++" MAINTAINS "++intercalate ", " [name rul | (_,rul)<-cl]
+                                     | cl<-eqCl fst (maintains pr), let role = fst (head cl)]
+      showRR :: Process -> String
+      showRR pr = intercalate "\n  " [ "ROLE "++role++" EDITS "++intercalate ", " [name rul | (_,rul)<-cl]
+                                     | cl<-eqCl fst (mayEdit pr), let role = fst (head cl)]
+
+instance ShowADL (String,Rule) where
+ showADL (role,rul) = "ROLE "++role++" MAINTAINS "++show (name rul)
+
+instance ShowADL (String,Declaration) where
+ showADL           (role,rel) = "ROLE "++role++" EDITS "++showADL rel
+
+instance ShowADL (String,Interface) where
+ showADL (role,ifc) = "ROLE "++role++" USES "++show (name ifc)
+ 
+instance ShowADL Pattern where
+ showADL pat
+  = "PATTERN " ++ showstr (name pat) ++ "\n"
+    ++ (if null (ptrls pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (ptrls pat)) ++ "\n")
+    ++ (if null (maintains pat) then "" else "\n  " ++                        showRM pat               ++ "\n")
+    ++ (if null (mayEdit pat)   then "" else "\n  " ++                        showRR pat               ++ "\n")
+    ++ (if null (ptgns pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (ptgns pat)) ++ "\n")
+    ++ (if null (ptdcs pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (ptdcs pat)) ++ "\n")
+    ++ (if null (conceptDefs pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (conceptDefs pat)) ++ "\n")
+    ++ (if null (ptids pat)  then "" else "\n  " ++intercalate "\n  " (map showADL (ptids pat)) ++ "\n")
+    ++ "ENDPATTERN"
+    where -- TODO: the following definitions should be unneccessary, but 'map showADL (maintains prc)' and "map showADL (mayEdit prc)" don't work... 
+      showRM :: Pattern -> String
+      showRM pt = intercalate "\n  " [ "ROLE "++role++" MAINTAINS "++intercalate ", " [name rul | (_,rul)<-cl]
+                                      | cl<-eqCl fst (maintains pt), let role = fst (head cl)]
+      showRR :: Pattern -> String
+      showRR pt = intercalate "\n  " [ "ROLE "++role++" EDITS "++intercalate ", " [name rul | (_,rul)<-cl]
+                                      | cl<-eqCl fst (mayEdit pt), let role = fst (head cl)]
+
+instance ShowADL (PairViewSegment Expression) where
+ showADL (PairViewText str)         = "TXT " ++ show str
+ showADL (PairViewExp srcOrTgt e) = showADL srcOrTgt ++ " " ++ showADL e
+
+instance ShowADL SrcOrTgt where
+ showADL Src = "source"
+ showADL Tgt = "target"
+ 
+--showADLSrcOrTgt :: SrcOrTgt -> String
+--showADLSrcOrTgt Src = "SRC"
+--showADLSrcOrTgt Tgt = "TGT"
+        
+instance ShowADL Rule where
+ showADL r
+  = "RULE \""++rrnm r++"\" : "++showADL (rrexp r)
+     ++ concat ["\n     MEANING "++showADL mng | mng <- ameaMrk $ rrmean r ]
+     ++ concat ["\n     MESSAGE "++showADL msg | msg <- rrmsg r]
+     ++ case rrviol r of
+          Nothing                -> ""
+          Just (PairView pvSegs) -> "\n     VIOLATION ("++intercalate ", " (map showADL pvSegs)++")"
+       
+instance ShowADL A_Gen where
+ showADL (Isa _ g s) = "CLASSIFY "++showADL s++" ISA "++showADL g
+ showADL (IsE _ g s) = "CLASSIFY "++showADL s++" IS "++intercalate " /\\ " (map showADL g)
+
+instance ShowADL RoleRelation where
+ showADL r
+  = "ROLE "++intercalate ", " (map show (rrRoles r))++" EDITS "++intercalate ", " (map showADL (rrRels r))
+
+instance ShowADL RoleRule where
+ showADL r = "ROLE "++intercalate ", " (map show (mRoles r))++" MAINTAINS "++intercalate ", " (map show (mRules r))
+
+instance ShowADL Interface where
+ showADL ifc 
+  = "INTERFACE "++showstr(name ifc)
+          ++(if null (ifcParams ifc) then [] else "("++intercalate ", " [showADL r | r<-ifcParams ifc]++")")
+          ++(if null (ifcArgs ifc) then [] else "{"++intercalate ", " [showstr(unwords strs) | strs<-ifcArgs ifc]++"}")
+          ++showADL (ifcObj ifc)
+
+instance ShowADL IdentityDef where
+ showADL identity 
+  = "IDENT "++idLbl identity
+          ++ ": " ++name (idCpt identity)
+          ++ "(" ++intercalate ", " (map showADL $ identityAts identity) ++ ")"
+
+instance ShowADL IdentitySegment where
+ showADL (IdentityExp objDef) = (if null (name objDef) then "" else "\""++name objDef++"\":") ++ showADL (objctx objDef)
+
+instance ShowADL ViewDef where
+ showADL vd 
+  = "VIEW "++vdlbl vd
+          ++ ": " ++name (vdcpt vd)
+          ++ "(" ++intercalate ", " (map showADL $ vdats vd) ++ ")"
+
+instance ShowADL ViewSegment where
+ showADL (ViewExp objDef) = (if null (name objDef) then "" else "\""++name objDef++"\":") ++ showADL (objctx objDef)
+ showADL (ViewText str) = "TXT " ++ show str
+ showADL (ViewHtml str) = "PRIMHTML " ++ show str
+
+-- showADL Relation only prints complete signatures to ensure unambiguity.
+-- therefore, when printing expressions, do not apply this function to print relations, but apply one that prints names only
+--instance ShowADL Relation where
+-- showADL rel = show rel
+
+instance ShowADL Expression where
+ showADL = showExpr (" = ", " |- ", " /\\ ", " \\/ ", " - ", " / ", " \\ ", ";", "!", "*", "*", "+", "~", ("-"++), "(", ")", "[", "*", "]") . insParentheses
+-- NOTE: retain space after \\, because of unexpected side effects if it is used just before an 'r' or 'n'....
+   where 
+     showExpr :: (String,String,String,String,String,String,String,String,String,String,String,String,String,String -> String,String,String,String,String,String)
+            -> Expression -> String
+     showExpr    (equi,  impl,  inter, union',diff,  lresi, rresi, rMul  , rAdd , rPrd ,closK0,closK1,flp',  compl,           lpar,  rpar,  lbr,   star,  rbr)
+      = showchar
+        where
+          showchar (EEqu (l,r)) = showchar l++equi++showchar r
+          showchar (EImp (l,r)) = showchar l++impl++showchar r
+          showchar (EIsc (l,r)) = showchar l++inter++showchar r
+          showchar (EUni (l,r)) = showchar l++union'++showchar r
+          showchar (EDif (l,r)) = showchar l++diff ++showchar r
+          showchar (ELrs (l,r)) = showchar l++lresi++showchar r
+          showchar (ERrs (l,r)) = showchar l++rresi++showchar r
+          showchar (ECps (EEps{},r)) = showchar  r
+          showchar (ECps (l,EEps{})) = showchar l
+          showchar (ECps (l,r)) = showchar l++rMul++showchar r
+          showchar (ERad (l,r)) = showchar l++rAdd++showchar r
+          showchar (EPrd (l,r)) = showchar l++rPrd++showchar r
+          showchar (EKl0 e)     = showchar e++closK0
+          showchar (EKl1 e)     = showchar e++closK1
+          showchar (EFlp e)     = showchar e++flp'
+          showchar (ECpl e)     = compl (showchar e)
+          showchar (EBrk e)     = lpar++showchar e++rpar
+          showchar (EDcD dcl)   = name dcl
+          showchar (EDcI c)     = "I"++lbr++name c++rbr
+          showchar  EEps{}      = ""
+          showchar (EDcV sgn)   = "V"++lbr++name (source sgn)++star++name (target sgn)++rbr
+          showchar (EMp1 a c)   = "'"++a++"'"++lbr++name c++rbr
+
+instance ShowADL DnfClause where
+ showADL dnfClause = showADL (dnf2expr dnfClause)
+
+{- SJ May 9th, 2013 @Han
+WHY is it forbidden to apply showADL to declarations that were not user defined?
+I got fatal 330 in RAP.adl, when generating a functional specification, so I hesitantly switched showADL on...
+instance ShowADL Declaration where
+ showADL decl = 
+  case decl of
+     Sgn{decusrX = False} -> fatal 323 "call to ShowADL for declarations may be done on user defined relations only." 
+     Sgn{} -> name decl++" :: "++name (source decl)++(if null ([Uni,Tot]>-multiplicities decl) then " -> " else " * ")++name (target decl)++
+              (let mults=if null ([Uni,Tot]>-multiplicities decl) then multiplicities decl>-[Uni,Tot] else multiplicities decl in
+               if null mults then "" else "["++intercalate "," (map showADL mults)++"]")++
+              (if null(decprL decl++decprM decl++decprR decl) then "" else
+               " PRAGMA "++unwords (map show [decprL decl,decprM decl,decprR decl]))
+               ++ concatMap meaning (ameaMrk (decMean decl))
+               ++ maybe "" (\(RelConceptDef srcOrTgt def) -> " DEFINE "++showADL srcOrTgt ++ " " ++ def) (decConceptDef decl)
+     Isn{}     -> fatal 330 ("Illegal call to ShowADL (Isn{"++show (detyp decl)++"}). Isn{} is of type Declaration and it is not user defined. A call to ShowADL for declarations may be done on user defined declarations only.")
+     Vs{}      -> fatal 332 ("Illegal call to ShowADL (Vs{}). Vs{} is of type Declaration and it is not user defined. A call to ShowADL for declarations may be done on user defined declarations only.")
+   where
+     meaning :: A_Markup -> String
+     meaning pmkup = " MEANING "++showADL pmkup
+-}
+instance ShowADL Declaration where
+ showADL decl = 
+  case decl of
+     Sgn{} -> name decl++" :: "++name (source decl)++(if null ([Uni,Tot]>-multiplicities decl) then " -> " else " * ")++name (target decl)++
+              (let mults=if null ([Uni,Tot]>-multiplicities decl) then multiplicities decl>-[Uni,Tot] else multiplicities decl in
+               if null mults then "" else "["++intercalate "," (map showADL mults)++"]")++
+              (if null(decprL decl++decprM decl++decprR decl) then "" else
+               " PRAGMA "++unwords (map show [decprL decl,decprM decl,decprR decl]))
+               ++ concatMap meaning (ameaMrk (decMean decl))
+               ++ maybe "" (\(RelConceptDef srcOrTgt def) -> " DEFINE "++showADL srcOrTgt ++ " " ++ def) (decConceptDef decl)
+     Isn{} -> "DECLARE I["++show (detyp decl)++"]" -- Isn{} is of type Declaration and it is implicitly defined
+     Vs{}  -> "DECLARE V"++show (decsgn decl)      -- Vs{}  is of type Declaration and it is implicitly defined
+   where
+     meaning :: A_Markup -> String
+     meaning pmkup = " MEANING "++showADL pmkup
+
+instance ShowADL P_Markup where
+ showADL (P_Markup lng fmt str) = case lng of
+                                     Nothing -> ""
+                                     Just l  -> "IN "++show l++" "
+                                 ++
+                                  case fmt of
+                                     Nothing -> ""
+                                     Just f  -> " "++show f++" "
+                                 ++
+                                  "{+"++str++"-} "
+ 
+instance ShowADL Prop where
+ showADL = show
+
+instance ShowADL A_Concept where
+ showADL c = show (name c)
+
+instance ShowADL ConceptDef where
+ showADL cd
+  = "\n  CONCEPT "++show (cdcpt cd)++" "++show (cddef cd)++" "++(if null (cdref cd) then "" else show (cdref cd))
+
+instance ShowADL A_Context where
+ showADL context
+  = "CONTEXT " ++name context
+    ++ (if null (ctxmetas context) then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxmetas context))++ "\n")
+    ++ (if null (ctxprocs context) then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxprocs context))++ "\n") -- All processes
+    ++ (if null (ctxifcs context)  then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxifcs context)) ++ "\n")
+    ++ (if null (ctxpats context)  then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxpats context)) ++ "\n")
+    ++ (if null (ctxrs context)    then "" else "\n"      ++intercalate "\n"   (map showADL (ctxrs context))   ++ "\n")
+    ++ (if null (ctxds context)    then "" else "\n"      ++intercalate "\n"   (map showADL (ctxds context))   ++ "\n")
+    ++ (if null (ctxks context)    then "" else "\n"      ++intercalate "\n"   (map showADL (ctxks context))   ++ "\n")
+    ++ (if null (ctxgs context)    then "" else "\n"      ++intercalate "\n"   (map showADL (ctxgs context))   ++ "\n")
+    ++ (if null cds                then "" else "\n"      ++intercalate "\n"   (map showADL  cds           )   ++ "\n")
+    ++ (if null (ctxpopus context) then "" else "\n"      ++intercalate "\n"   (map showADL (ctxpopus context))++ "\n")
+    ++ (if null (ctxsql context)   then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxsql context)) ++ "\n")
+    ++ (if null (ctxphp context)   then "" else "\n"      ++intercalate "\n\n" (map showADL (ctxphp context)) ++ "\n")
+    ++ "\n\nENDCONTEXT"
+    where --showADLpops = [ showADL Popu{popm=makeRelation d, popps=decpopu d}
+     --                   | d<-declarations context, decusr d, not (null (decpopu d))]
+     --                   ++ [showADL (P_CptPopu{p_popm=name c, p_popps=[(a,a) | a<-atomsOf c]}) | c<-concs context, c/=ONE, not(null (atomsOf c))]
+          cds = conceptDefs context >- (concatMap conceptDefs (ctxpats context) ++ concatMap conceptDefs (ctxprocs context))
+
+instance ShowADL Fspc where
+ showADL fSpec
+  = "CONTEXT " ++name fSpec
+    ++ (if null (map ifcObj [] {- map fsv_ifcdef (fActivities fSpec) -})     
+        then "" 
+        else "\n"++intercalate "\n\n" (map (showADL . ifcObj) [] {- map fsv_ifcdef (fActivities fSpec) -})     ++ "\n")
+    ++ (if null (metas fSpec)    then "" else "\n"++intercalate "\n\n" (map showADL (metas fSpec))    ++ "\n")
+    ++ (if null (patterns fSpec)    then "" else "\n"++intercalate "\n\n" (map showADL (patterns fSpec))    ++ "\n")
+    ++ (if null cds then "" else "\n"++intercalate "\n"   (map showADL cds) ++ "\n")
+    ++ (if null (gens fSpec) then "" else "\n"++intercalate "\n"   (map showADL (gens fSpec)) ++ "\n")
+    ++ (if null (identities fSpec)       then "" else "\n"++intercalate "\n"   (map showADL (identities fSpec >- concatMap identities (patterns fSpec)))       ++ "\n")
+    ++ (if null (declarations fSpec) then "" else "\n"++intercalate "\n"   (map showADL (declarations fSpec >- concatMap declarations (patterns fSpec))) ++ "\n")
+    ++ (if null (udefrules fSpec) then "" else "\n"++intercalate "\n"   (map showADL (udefrules fSpec >- concatMap udefrules (patterns fSpec))) ++ "\n")
+    ++ (if null (fSexpls fSpec) then "" else "\n"++intercalate "\n"   (map showADL (fSexpls fSpec)) ++ "\n")
+    ++ "TODO: Populations are not shown..\n" --TODO.
+--    ++ (if null showADLpops         then "" else "\n"++intercalate "\n\n" showADLpops                                    ++ "\n")
+    ++ (if null (interfaceS fSpec)    then "" else "\n"++intercalate "\n\n" (map showADL (interfaceS fSpec))    ++ "\n")
+    ++ "\n\nENDCONTEXT"
+    where --showADLpops = [ showADL Popu{popm=makeRelation d, popps=decpopu d}
+      --                  | d<-declarations fSpec, decusr d, not (null (decpopu d))]
+      --                  ++ [showADL (P_CptPopu{p_popm=name c, p_popps=[(a,a) | a<-atomsOf c]}) | c<-concs fSpec, c/=ONE, not(null (atomsOf c))]
+          cds = vConceptDefs fSpec >- (concatMap conceptDefs patts ++ concatMap (conceptDefs.fpProc) procs)
+          patts = if null (themes fSpec)
+                  then patterns fSpec
+                  else [ pat | pat<-patterns fSpec, name pat `elem` themes fSpec ]
+          procs = if null (themes fSpec)
+                  then vprocesses fSpec
+                  else [ prc | prc<-vprocesses fSpec, name prc `elem` themes fSpec ]
+
+instance ShowADL ECArule where
+  showADL eca = "ECA #"++show (ecaNum eca)
+instance ShowADL Event where
+  showADL = show
+instance (ShowADL a, ShowADL b) => ShowADL (a,b) where
+ showADL (a,b) = "(" ++ showADL a ++ ", " ++ showADL b ++ ")"
+
+instance ShowADL P_Population where
+ showADL pop
+  = "POPULATION "++name pop
+  ++ case pop of
+        P_TRelPop{} -> "["++(name.pSrc.p_type) pop++"*"++(name.pTrg.p_type) pop++"]"
+        _ -> ""
+  ++ " CONTAINS\n"
+  ++ if (case pop of
+            P_RelPopu{} -> null (p_popps pop)
+            P_TRelPop{} -> null (p_popps pop)
+            P_CptPopu{} -> null (p_popas pop)
+        ) 
+     then "" 
+     else indent++"[ "++intercalate ("\n"++indent++", ") showContent++indent++"]"
+    where indent = "   "
+          showContent = case pop of
+                          P_RelPopu{} -> map showPaire (p_popps pop)
+                          P_TRelPop{} -> map showPaire (p_popps pop)
+                          P_CptPopu{} -> map showAtom  (p_popas pop)
+showPaire :: Paire -> String
+showPaire p = showAtom (srcPaire p)++" * "++ showAtom (trgPaire p)
+
+instance ShowADL Population where
+ showADL pop
+  = "POPULATION "
+  ++ case pop of
+        PRelPopu{} -> (name.popdcl) pop++(show.sign.popdcl) pop
+        PCptPopu{} -> (name.popcpt) pop
+  ++ " CONTAINS\n"
+  ++ if (case pop of
+            PRelPopu{} -> null (popps pop)
+            PCptPopu{} -> null (popas pop)
+        ) 
+     then "" 
+     else indent++"[ "++intercalate ("\n"++indent++", ") showContent++indent++"]"
+    where indent = "   "
+          showContent = case pop of
+                          PRelPopu{} -> map showPaire (popps pop)
+                          PCptPopu{} -> map showAtom  (popas pop)
+
+
+-- showADL (PRelPopu r pairs)
+--  = "POPULATION "++showADL r++" CONTAINS\n"++
+--    indent++"[ "++intercalate ("\n"++indent++", ") (map (\(x,y)-> showatom x++" * "++ showatom y) pairs)++indent++"]"
+--    where indent = "   "
+
+
+showAtom :: String -> String
+showAtom x = "'"++[if c=='\'' then '`' else c|c<-x]++"'"              
+
+instance ShowADL TermPrim where
+ showADL (PI _)                                   = "I"
+ showADL (Pid _ c)                                = "I["++showADL c++"]"
+ showADL (Patm _ a Nothing)                       = "'"++a++"'"
+ showADL (Patm _ a (Just c))                      = "'"++a++"'["++show c++"]"
+ showADL (PVee _)                                 = "V"
+ showADL (Pfull _ s t)                            = "V["++show s++"*"++show t++"]"
+ showADL (Prel _ rel)                             = rel
+ showADL (PTrel _ rel psgn)                       = rel++showsign psgn
+  where     showsign (P_Sign src trg)                         = "["++showADL src++"*"++showADL trg++"]"
+
+
+--used to compose error messages at p2a time
+instance (ShowADL a, Traced a) => ShowADL (Term a) where
+ showADL = showPExpr (" = ", " |- ", " /\\ ", " \\/ ", " - ", " / ", " \\ ", ";", "!", "*", "*", "+", "~", "(", ")")
+   where
+    showPExpr (equi,impl,inter,union',diff,lresi,rresi,rMul,rAdd,rPrd,closK0,closK1,flp',lpar,rpar) expr
+     = showchar (insP_Parentheses expr)
+      where
+       showchar (Prim a) = showADL a
+       showchar (Pequ _ l r)                             = showchar l++equi++showchar r
+       showchar (Pimp _ l r)                             = showchar l++impl++showchar r
+       showchar (PIsc _ l r)                             = showchar l++inter++showchar r
+       showchar (PUni _ l r)                             = showchar l++union'++showchar r
+       showchar (PDif _ l r)                             = showchar l++diff ++showchar r
+       showchar (PLrs _ l r)                             = showchar l++lresi++showchar r
+       showchar (PRrs _ l r)                             = showchar l++rresi++showchar r
+       showchar (PCps _ l r)                             = showchar l++rMul++showchar r
+       showchar (PRad _ l r)                             = showchar l++rAdd++showchar r
+       showchar (PPrd _ l r)                             = showchar l++rPrd++showchar r
+       showchar (PKl0 _ e)                               = showchar e++closK0
+       showchar (PKl1 _ e)                               = showchar e++closK1
+       showchar (PFlp _ e)                               = showchar e++flp'
+       showchar (PCpl _ e)                               = '-':showchar e
+       showchar (PBrk _ e)                               = lpar++showchar e++rpar
+
+insP_Parentheses :: (Traced a) => Term a -> Term a
+insP_Parentheses = insPar 0
+      where
+       wrap :: (Traced a) => Integer -> Integer -> Term a -> Term a
+       wrap i j e' = if i<=j then e' else PBrk (origin e') e'
+       insPar :: (Traced a) => Integer -> Term a -> Term a
+       insPar i (Pequ o l r) = wrap i     0 (Pequ o (insPar 1 l) (insPar 1 r))
+       insPar i (Pimp o l r) = wrap i     0 (Pimp o (insPar 1 l) (insPar 1 r))
+       insPar i (PIsc o l r) = wrap (i+1) 2 (PIsc o (insPar 2 l) (insPar 2 r))
+       insPar i (PUni o l r) = wrap (i+1) 2 (PUni o (insPar 2 l) (insPar 2 r))
+       insPar i (PDif o l r) = wrap i     4 (PDif o (insPar 5 l) (insPar 5 r))
+       insPar i (PLrs o l r) = wrap i     6 (PLrs o (insPar 7 l) (insPar 7 r))
+       insPar i (PRrs o l r) = wrap i     6 (PRrs o (insPar 7 l) (insPar 7 r))
+       insPar i (PCps o l r) = wrap (i+1) 8 (PCps o (insPar 8 l) (insPar 8 r))
+       insPar i (PRad o l r) = wrap (i+1) 8 (PRad o (insPar 8 l) (insPar 8 r))
+       insPar i (PPrd o l r) = wrap (i+1) 8 (PPrd o (insPar 8 l) (insPar 8 r))
+       insPar _ (PKl0 o e)   = PKl0 o (insPar 10 e)
+       insPar _ (PKl1 o e)   = PKl1 o (insPar 10 e)
+       insPar _ (PFlp o e)   = PFlp o (insPar 10 e)
+       insPar _ (PCpl o e)   = PCpl o (insPar 10 e)
+       insPar i (PBrk _ e)   = insPar i e
+       insPar _ x            = x
+
+
+--used to compose error messages at p2a time
+instance ShowADL P_Concept where
+ showADL = name
+
+instance ShowADL PAclause where
+    showADL = showPAclause "\n "
+     where
+      showPAclause indent pa@CHC{}
+       = let indent'=indent++"   " in "execute ONE from"++indent'++intercalate indent' [showPAclause indent' p' | p'<-paCls pa]
+      showPAclause indent pa@ALL{}
+       = let indent'=indent++"   " in "execute ALL of"++indent'++intercalate indent' [showPAclause indent' p' | p'<-paCls pa]
+      showPAclause indent pa@Do{}
+       = ( case paSrt pa of
+            Ins -> "INSERT INTO "
+            Del -> "DELETE FROM ")++
+         show (paTo pa)++
+         " SELECTFROM "++
+         show (paDelta pa)
+         ++concat [ indent++showConj rs | (_,rs)<-paMotiv pa ]
+      showPAclause indent pa@Sel{}
+       = let indent'=indent++"   " in
+        "SELECT x:"++show (paCpt pa)++" FROM "++showADL (paExp pa)++";"++indent'++showPAclause indent' (paCl pa "x")
+      showPAclause indent pa@New{}
+       = let indent'=indent++"   " in
+        "CREATE x:"++show (paCpt pa)++";"++indent'++showPAclause indent' (paCl pa "x")
+      showPAclause indent pa@Rmv{}
+       = let indent'=indent++"   " in
+        "REMOVE x:"++show (paCpt pa)++";"++indent'++showPAclause indent' (paCl pa "x")
+      showPAclause _ Nop{} = "Nop"
+      showPAclause _ Blk{} = "Blk"
+      showPAclause _ (Let _ _ _) = fatal 390 "showPAclause not defined for `Let`. Consult your dealer!"
+      showPAclause _ (Ref _)     = fatal 391 "showPAclause not defined for `Ref`. Consult your dealer!"
+      showConj rs
+              = "(TO MAINTAIN"++intercalate ", " [name r | r<-rs]++")"
+ src/lib/DatabaseDesign/Ampersand/Fspec/ShowECA.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Fspec.ShowECA (showECA) where
+   import DatabaseDesign.Ampersand.Fspec.Fspec
+   import DatabaseDesign.Ampersand.Basics                       (fatalMsg,Identified(..))
+   import DatabaseDesign.Ampersand.Fspec.ShowADL            (ShowADL(..))
+   import Data.List (intercalate)
+
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Fspec.ShowECA"
+
+
+   class ECA a where 
+    showECA :: Fspc -> String -> a -> String
+
+   instance ECA ECArule where
+    showECA fSpec indent er = showECA fSpec indent (ecaTriggr er)++ " EXECUTE    -- (ECA rule "
+                                                                 ++ show (ecaNum er)
+                                                                 ++ ")"
+                                                                 ++
+                              indent++showECA fSpec indent (ecaAction er)
+   instance ECA Event where
+    showECA _ _ (On Ins rel) = "ON INSERT Delta IN " ++ showADL rel
+    showECA _ _ (On Del rel) = "ON DELETE Delta FROM " ++ showADL rel
+
+   instance ECA PAclause where
+    showECA _ = showPAclause
+     where
+      showPAclause :: String -> PAclause -> String
+      showPAclause indent pa@Do{}
+       = ( case paSrt pa of
+            Ins -> "INSERT INTO "
+            Del -> "DELETE FROM ")++
+         showADL (paTo pa)++
+         " SELECTFROM"++indent++"  "++
+         showADL (paDelta pa)++
+         motivate indent "TO MAINTAIN" (paMotiv pa)
+      showPAclause indent (New c clause cj_ruls)
+       = "CREATE x:"++show c++";"++indent'++showPAclause indent' (clause "x")++motivate indent "MAINTAINING" cj_ruls
+         where indent'  = indent++"  "
+      showPAclause indent (Rmv c clause cj_ruls)
+       = "REMOVE x:"++show c++";"++indent'++showPAclause indent' (clause "x")++motivate indent "MAINTAINING" cj_ruls
+         where indent'  = indent++"  "
+      showPAclause indent (Sel c e r cj_ruls)
+       = "SELECT x:"++show c++" FROM codomain("++ showADL e ++");"
+                 ++indent'++showPAclause indent' (r "x")++motivate indent "MAINTAINING" cj_ruls
+         where indent'  = indent++"  "
+      showPAclause indent (CHC ds cj_ruls)
+       = "ONE of "++intercalate indent' [showPAclause indent' d | d<-ds]++motivate indent "MAINTAINING" cj_ruls
+         where indent'  = indent++"       "
+      showPAclause indent (ALL ds cj_ruls)
+       = "ALL of "++intercalate indent' [showPAclause indent' d | d<-ds]++motivate indent "MAINTAINING" cj_ruls
+         where indent'  = indent++"       "
+      showPAclause indent (Nop cj_ruls)
+       = "DO NOTHING"++motivate indent "TO MAINTAIN" cj_ruls
+      showPAclause indent (Blk cj_ruls)
+       = "BLOCK"++motivate indent "CANNOT CHANGE" cj_ruls
+      showPAclause  _ (Let _ _ _)  = fatal 55 "showPAclause is missing for `Let`. Contact your dealer!"
+      showPAclause  _ (Ref _)      = fatal 56 "showPAclause is missing for `Ref`. Contact your dealer!"
+                     
+      motivate indent motive motives = concat [ indent++showConj cj_rul | cj_rul<-motives ]
+         where showConj (conj,rs) = "("++motive++" "++showADL conj++" FROM "++intercalate ", " (map name rs) ++")"
+ src/lib/DatabaseDesign/Ampersand/Fspec/ShowHS.hs view
@@ -0,0 +1,968 @@+{-# OPTIONS_GHC -Wall -XFlexibleInstances #-}+module DatabaseDesign.Ampersand.Fspec.ShowHS (ShowHS(..),ShowHSName(..),fSpec2Haskell,haskellIdentifier)+where+   import DatabaseDesign.Ampersand.Core.ParseTree+   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree+   import Text.Pandoc hiding (Meta)+   import Data.Char                  (isAlphaNum)+   import DatabaseDesign.Ampersand.Basics+   import DatabaseDesign.Ampersand.Fspec.Plug+   import DatabaseDesign.Ampersand.Fspec.Fspec+--   import DatabaseDesign.Ampersand.Fspec.ShowADL    (ShowADL(..))  -- for traceability, we generate comment in the Haskell code.+--   import DatabaseDesign.Ampersand.Fspec.FPA   (fpa)+   import Data.List+   import DatabaseDesign.Ampersand.Classes+   import qualified DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner+   import DatabaseDesign.Ampersand.Misc+   import Data.Hashable+   import Data.Ord+   import Data.Function+   +   fatal :: Int -> String -> a+   fatal = fatalMsg "Fspec.ShowHS"++   fSpec2Haskell :: Fspc -> Options -> String+   fSpec2Haskell fSpec flags+           = "{-# OPTIONS_GHC -Wall #-}"+             ++"\n{-Generated code by "++ampersandVersionStr++" at "++show (genTime flags)++"-}"+             ++"\nmodule Main where"+--             ++"\n  import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner"+--             ++"\n  import DatabaseDesign.Ampersand.Core.ParseTree"+--             ++"\n  import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree"+--             ++"\n  import DatabaseDesign.Ampersand.Fspec.ShowHS (showHS)"+--             ++"\n  import DatabaseDesign.Ampersand.Fspec.Fspec"+--             ++"\n  import DatabaseDesign.Ampersand.Misc (getOptions)"+--             ++"\n  import DatabaseDesign.Ampersand.Basics"+--             ++"\n  import DatabaseDesign.Ampersand.Classes"+             ++"\n  import DatabaseDesign.Ampersand"+             ++"\n  import Text.Pandoc hiding (Meta)"+             ++"\n  import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)"+             ++"\n"+             ++"\n  main :: IO ()"+             ++"\n  main = do flags <- getOptions"+             ++"\n            putStr (showHS flags \"\\n  \" fSpec_"++baseName flags++")"+             ++"\n  fSpec_"++baseName flags++" :: Fspc"+             ++"\n  fSpec_"++baseName flags++"\n   = "++showHS flags "\n     " fSpec+++   wrap :: String->String->(String->a->String)->[a]->String+   wrap initStr indent f xs+    = initStr+++      case xs of+        []  -> "[]"+        [x] -> "[ "++f (indent++"  ") x++" ]"+        _   -> "[ "++intercalate (indent++", ") [f (indent++"  ") x | x<-xs]++indent++"]"++   class ShowHSName a where+    showHSName :: a -> String+    +   class ShowHS a where+    showHS :: Options -> String -> a -> String++   instance ShowHSName a => ShowHSName [a] where+    showHSName xs = "["++intercalate "," (map showHSName xs)++"]"+   +   instance ShowHS a => ShowHS [a] where+    showHS flags indent = wrap "" (indent++" ") (showHS flags)+    +   instance ShowHSName a => ShowHSName (Maybe a) where+    showHSName Nothing  = "Nothing"+    showHSName (Just x) = showHSName x+    +   instance ShowHS a => ShowHS (Maybe a) where+    showHS _ _ Nothing  = "Nothing"+    showHS flags indent (Just x) = "Just (" ++ showHS flags indent x ++ ")"+++   instance (ShowHSName a , ShowHSName b) => ShowHSName (a,b) where +    showHSName (a,b) = "( "++showHSName a++" , "++showHSName b++" )"+   -- | The following is used to showHS flags for signs: (Concept, Concept)+   instance (ShowHS a , ShowHS b) => ShowHS (a,b) where+    showHS flags indent (a,b) = "("++showHS flags (indent++" ") a++","++showHS flags (indent++" ") b++")"+  +   ++   instance ShowHSName PlugSQL where+    showHSName plug = haskellIdentifier ("plug_"++name plug)++   instance ShowHS PlugSQL where+    showHS flags indent plug+      = case plug of+          TblSQL{} -> intercalate indent +                      ["let " ++ intercalate (indent++"    ")+                                             [showHSName f++indent++"     = "++showHS flags (indent++"       ") f | f<-fields plug] ++indent++"in"+                      ,"TblSQL { sqlname = " ++ (show.name) plug+                      ,"       , fields  = ["++intercalate ", " (map showHSName (fields plug))++"]"+                      ,"       , cLkpTbl = [ "++intercalate (indent++"                   , ") ["("++showHSName c++", "++showHSName cn++")" | (c,cn)<-cLkpTbl plug] ++ "]"+                      ,"       , mLkpTbl = [ "++intercalate (indent++"                   , ") ["("++showHS flags "" r++", "++showHSName ms++", "++showHSName mt++")" | (r,ms,mt)<-mLkpTbl plug] ++ "]"+                  --    ,"       , sqlfpa  = " ++ showHS flags "" (fpa plug)+                      ,"       }"+                      ]+          BinSQL{} -> intercalate indent +                      ["let " ++ showHSName (fst (columns plug))++indent++"     = "++showHS flags (indent++"       ") (fst (columns plug))+                              ++ (indent++"    ") ++ showHSName (snd (columns plug))++indent++"     = "++showHS flags (indent++"       ") (snd (columns plug))+                              ++indent++"in"+                      ,"BinSQL { sqlname = " ++ (show.name) plug+                      ,"       , columns = ("++showHSName (fst (columns plug))++ ", " ++showHSName (snd (columns plug))++")"+                      ,"       , cLkpTbl = [ "++intercalate (indent++"                   , ") ["("++showHSName c++", "++showHSName cn++")" | (c,cn)<-cLkpTbl plug] ++ "]"+                      ,"       , mLkp = "++showHS flags "" (mLkp plug)+                  --    ,"       , sqlfpa  = " ++ showHS flags "" (fpa plug)+                      ,"       }"+                      ]+          ScalarSQL{} -> intercalate indent +                      ["ScalarSQL { sqlname   = "++ (show.name) plug+                      ,"          , sqlColumn = "++ showHS flags (indent++"                     ") (sqlColumn plug)+                      ,"          , cLkp      = "++ showHSName (cLkp plug)+                  --    ,"          , sqlfpa    = "++ showHS flags "" (fpa plug)+                      ,"          }"+                      ]++   instance ShowHSName (ECArule) where+    showHSName r = "ecaRule"++show (ecaNum r)++   instance ShowHS (ECArule) where+    showHS flags indent r   +      =         "ECA { ecaTriggr = " ++ showHS flags "" (ecaTriggr r) +++        indent++"    , ecaDelta  = " ++ showHS flags (indent++"                  ")  (ecaDelta r)+++        indent++"    , ecaAction = " ++ showHS flags (indent++"                  ")  (ecaAction r)+++        indent++"    , ecaNum    = " ++ show (ecaNum r)+++        indent++"    }"++   instance ShowHS Event where+    showHS _ indent e   +      = if "\n" `isPrefixOf` indent+        then "On " ++ show (eSrt e)++indent++"   " ++ showHSName (eDcl e)++indent++"   "+        else "On " ++ show (eSrt e)++          " " ++ showHSName (eDcl e)++           ""++   instance ShowHS PAclause where+    showHS flags indent p   +      = case p of+           CHC{} -> wrap "CHC " (indent ++"    ") (showHS flags) (paCls p)+++                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms+           ALL{} -> wrap "ALL " (indent ++"    ") (showHS flags) (paCls p)+++                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms+           Do{}  ->  "Do "++show (paSrt p)++ " ("++showHS flags (indent++"        ") (paTo p)++indent++"       )"+++                            indent++"       ("++showHS flags (indent++"        ") (paDelta p)++indent++"       )"+++                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms+           New{} -> "New ("++showHS flags "" (paCpt p)++")"+++                    indent++"    (\\x->"++showHS flags (indent++"        ") (paCl p "x")++indent++"    )"+++                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms+           Rmv{} -> "Rmv ("++showHS flags "" (paCpt p)++")"+++                    indent++"    (\\x->"++showHS flags (indent++"        ") (paCl p "x")++indent++"    )"+++                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms+           Sel{} -> "Sel ("++showHS flags "" (paCpt p)++")"+++                    indent++"    ( "++showHS flags (indent++"      ") (paExp p)++indent++"    )"+++                    indent++"    (\\x->"++showHS flags (indent++"        ") (paCl p "x")++indent++"    )"+++                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms+           Nop{} -> "Nop "++wrap "" (indent ++"    ") showMotiv ms+           Blk{} -> "Blk "++wrap "" (indent ++"    ") showMotiv ms+           Let{} -> wrap "Let " (indent ++"    ") (showHS flags) (paCls p)+++                    "TODO: paBody of Let clause"+++                    wrap (if null ms then "" else indent ++"    ") (indent ++"    ") showMotiv ms             +           Ref{} -> "Ref "++paVar p+        where ms = paMotiv p+              showMotiv ind (conj,rs) = "("++showHS flags (ind++" ") conj++", "++showHSName rs++")"++   instance ShowHSName SqlField where+    showHSName sqFd = haskellIdentifier ("sqlFld_"++fldname sqFd)++   instance ShowHS SqlField where+    showHS flags indent sqFd+      = intercalate indentA+          [  "Fld { fldname = " ++ show (fldname sqFd)+          ,      ", fldexpr = " ++ showHS flags indentB (fldexpr sqFd)+          ,      ", fldtype = " ++ showHS flags "" (fldtype sqFd)+          ,      ", flduse  = " ++ showHS flags "" (flduse sqFd)+          ,      ", fldnull = " ++ show (fldnull sqFd)+          ,      ", flduniq = " ++ show (flduniq sqFd)+          ,      "}"+          ] where indentA = indent ++"    "         -- adding the width of "Fld "+                  indentB = indentA++"            " -- adding the width of ", fldexpr = " ++   instance ShowHS SqlFieldUsage where+    showHS _ _ (PrimKey aCpt)    = "PrimKey "   ++showHSName aCpt+    showHS _ _ (ForeignKey aCpt) = "ForeignKey "++showHSName aCpt+    showHS _ _ PlainAttr         = "PlainAttr "+    showHS _ _ NonMainKey        = "NonMainKey "+    showHS _ _ UserDefinedUsage  = "UserDefinedUsage "+    showHS _ _ FillInLater       = "FillInLater "++   instance ShowHS SqlType where+    showHS _ indent (SQLChar i)    = indent++"SQLChar   "++show i+    showHS _ indent SQLBlob        = indent++"SQLBlob   "+    showHS _ indent SQLPass        = indent++"SQLPass   "+    showHS _ indent SQLSingle      = indent++"SQLSingle "+    showHS _ indent SQLDouble      = indent++"SQLDouble "+    showHS _ indent SQLText        = indent++"SQLText   "+    showHS _ indent (SQLuInt i)    = indent++"SQLuInt   "++show i+    showHS _ indent (SQLsInt i)    = indent++"SQLsInt   "++show i+    showHS _ indent SQLId          = indent++"SQLId     "+    showHS _ indent (SQLVarchar i) = indent++"SQLVarchar "++show i+    showHS _ indent SQLBool        = indent++"SQLBool   "++   instance ShowHSName Quad where+    showHSName q+      = haskellIdentifier ("quad_"++(showHSName.qDcl) q++"_"++name (case q of +                                                                        Quad{} -> (cl_rule.qClauses) q+                                                                        LoopSearchQuad{} -> qRule q+                                                                   ))+   instance ShowHS Quad where+    showHS flags indent q +      = intercalate indent+         (case q of+           Quad{} ->+               [ "Quad{ qDcl     = " ++ showHSName (qDcl q)+               , "    , qClauses = " ++ showHS flags newindent (qClauses q)+               , "    }"+               ]+           LoopSearchQuad{} ->+               [ "LoopSearchQuad{ qDcl     = " ++ showHSName (qDcl q)+               , "              , qRule    = " ++ showHSName (qRule q)+               , "              , debugStr = " ++ debugStr q+               , "              }"+               ]+          )+       where+         newindent = indent ++ "                 "+         +   instance ShowHS Fswitchboard where+    showHS flags indent fsb+      = intercalate indent+          [ "Fswtch { fsbEvIn  = " ++ showHS flags newindent (fsbEvIn  fsb)+          , "       , fsbEvOut = " ++ showHS flags newindent (fsbEvOut fsb)+          ,wrap+            "       , fsbConjs = " newindent' (\_->shConj) (fsbConjs  fsb)+          ,wrap+            "       , fsbECAs  = " newindent' (\_->showHSName) (fsbECAs  fsb)+          , "       }"+          ]+       where +         newindent   = indent ++ "                   "+         newindent'  = newindent ++ " "+         newindent'' = newindent' ++ "    "+         shConj (r,conj) = "( "++showHSName r++newindent++"   , "++showHS flags newindent'' conj++newindent++"   )"++   instance ShowHS Clauses where+    showHS _ indent c+      = intercalate indent+          [ "Clauses{ cl_conjNF = " ++ showHSName (cl_conjNF c)+          , "       , cl_rule   = " ++ showHSName (cl_rule c)+          , "       }"+          ]++   instance ShowHS DnfClause where+    showHS flags indent (Dnf antcs conss)+      = intercalate indent+          [ wrap "Dnf " (indent++"   ") (\_->showHS flags (indent++"      ")) antcs+          , wrap "    " (indent++"   ") (\_->showHS flags (indent++"      ")) conss+          ]++   instance ShowHSName RuleClause where+    showHSName x = haskellIdentifier ("conj_"++rc_rulename x++"["++show (rc_int x)++"]")+    +   instance ShowHS RuleClause where+    showHS flags indent x+      = intercalate (indent ++"  ")+          [   "RC{ rc_int        = " ++ show (rc_int x)+          ,     ", rc_rulename   = " ++ show (rc_rulename x)+          ,     ", rc_conjunct   = " ++ showHS flags indentA (rc_conjunct x)+          ,wrap ", rc_dnfClauses = " indentA (\_->showHS flags (indentA++"  ")) (rc_dnfClauses x)+          ,     "}" +          ]+        where indentA = indent ++"                    "++   instance ShowHSName Fspc where+    showHSName fspec = haskellIdentifier ("fSpc_"++name fspec)+   +   instance ShowHS Fspc where+    showHS flags indent fspec+     = intercalate (indent ++"    ") +           [ "Fspc{ fsName        = " ++ show (name fspec)+           ,wrap ", fspos         = " indentA (showHS flags) (fspos fspec)+           ,     ", fsLang        = " ++ show (fsLang fspec) ++ "  -- the default language for this specification"+           ,     ", themes        = " ++ show (themes fspec) ++ "  -- the names of themes to be printed in the documentation, meant for partial documentation.  Print all if empty..."+           ,wrap ", vprocesses    = " indentA (\_->showHSName) (vprocesses fspec)+           ,wrap ", vplugInfos    = " indentA (\_->showHS flags (indentA++"  ")) (vplugInfos fspec)+           ,wrap ", plugInfos     = " indentA (\_->showHS flags (indentA++"  ")) (plugInfos  fspec)+           ,     ", interfaceS    = interfaceS'"+           ,     ", interfaceG    = interfaceG'"+           ,     ", fSwitchboard  = "++showHS flags indentA (fSwitchboard fspec)+           ,wrap ", fActivities   = " indentA (\_->showHS flags (indentA++"  ")) (fActivities fspec)+           ,     ", fRoleRels     = " +++                 case fRoleRels fspec of+                   []        -> "[]"+                   [(r,rel)] -> "[ ("++show r++", "++showHS flags "" rel++") ]"+                   _         -> "[ "++intercalate (indentA++", ") ["("++show r++","++showHS flags "" rel++")" | (r,rel)<-fRoleRels fspec]++indentA++"]"+           ,     ", fRoleRuls     = " +++                 case fRoleRuls fspec of+                   []        -> "[]"+                   [(r,rul)] -> "[ ("++show r++", "++showHSName rul++") ]"+                   _         -> "[ "++intercalate (indentA++", ") ["("++show r++","++showHSName rul++")" | (r,rul)<-fRoleRuls fspec]++indentA++"]"+           ,wrap ", vrules        = " indentA (\_->showHSName) (vrules fspec)+           ,wrap ", grules        = " indentA (\_->showHSName) (grules fspec)+           ,wrap ", invars        = " indentA (\_->showHSName) (invars fspec)+           ,wrap ", allRules      = " indentA (\_->showHSName) (allRules fspec)+           ,wrap ", allUsedDecls  = " indentA (\_->showHSName) (allUsedDecls fspec)+           ,wrap ", allDecls      = " indentA (\_->showHSName) (allDecls fspec)+           ,wrap ", allConcepts   = " indentA (\_->showHSName) (allConcepts fspec)+           ,wrap ", kernels       = " indentA (\_->showHSName) (kernels fspec)+           ,wrap ", vIndices      = " indentA (\_->showHSName) (vIndices fspec)+           ,wrap ", vviews        = " indentA (\_->showHSName) (vviews fspec)+           ,wrap ", vgens         = " indentA (showHS flags)   (vgens fspec)+           ,wrap ", vconjs        = " indentA (\_->showHSName) (vconjs fspec)+           ,wrap ", vquads        = " indentA (\_->showHSName) (vquads fspec)+           ,wrap ", vEcas         = " indentA (\_->showHSName) (vEcas fspec)+           ,wrap ", vrels         = " indentA (\_->showHSName) (vrels fspec)+           ,     ", fsisa         = isa'"+           ,wrap ", vpatterns     = " indentA (\_->showHSName) (patterns fspec)+           ,wrap ", vConceptDefs  = " indentA (\_->showHSName) (vConceptDefs fspec)+           ,wrap ", fSexpls       = " indentA (showHS flags)   (fSexpls fspec)+           ,     ", metas         = allMetas"+           ,wrap ", initialPops   = " indentA (showHS flags)   (initialPops fspec)+           ,wrap ", allViolations = " indentA showViolatedRule (allViolations fspec)+           ,"}" +           ] ++   +       indent++"where"+++       indent++" isa' :: [(A_Concept, A_Concept)]"+++       indent++" isa'  = "++    showHSName (fsisa fspec)+++        "\n -- ***Interfaces Specified in Ampersand script***: "+++       indent++" interfaceS' = "++(if null (interfaceS fspec) then "[]" else+                                 "[ "++intercalate (indentB++", ") (map showHSName (interfaceS fspec))++indentB++"]")+++        "\n -- ***Activities Generated by the Ampersand compiler ***: " +++       indent++" interfaceG' = "++(if null (interfaceG fspec) then "[]" else+                                 "[ "++intercalate (indentB++", ") (map showHSName (interfaceG fspec))++indentB++"]")+++       indent++" allMetas = "++(if null (metas fspec) then "[]" else+                                 "[ "++intercalate (indentB++", ") (map (showHS flags (indent ++ "         ")) (metas fspec))++indentB++"]") +++       (if null (patterns fspec ) then "" else "\n -- ***Patterns***: "++concat [indent++" "++showHSName p++indent++"  = "++showHS flags (indent++"    ") p |p<-patterns fspec ]++"\n")++++-- WHY?  staan hier verschillende lijstjes met interfaces?+-- BECAUSE! Een Ampersand engineer besteedt veel tijd om vanuit een kennismodel (lees: een graaf met concepten en relaties)+--          alle interfaces met de hand te verzinnen.+--          Je kunt natuurlijk ook een interfaces-generator aan het werk zetten, die een aantal interfaces klaarzet bij wijze+--          van steiger (scaffold). Dat bespaart een hoop werk. De functie interfaceG is zo'n generator.+--          Door de gegenereerde interfaces af te drukken, kun je dus heel snel Ampersand sourcecode maken met correct-vertaalbare interfaces.+--          Heb je eenmaal een goed werkend pakket interfaces, dan wil je wellicht alleen de door jezelf gespecificeerde interfaces+--          gebruiken. Dat gebeurt in interfaceS.++       (if null  (interfaceS fspec) then ""  else+        "\n -- *** User defined interfaces (total: "++(show.length.interfaceS) fspec++" interfaces) ***: "+++        concat [indent++" "++showHSName s++indent++"  = "++showHS flags (indent++"    ") s | s<-interfaceS fspec]++"\n"+       )+++       (if null (interfaceG fspec ) then "" else+        "\n -- *** Generated interfaces (total: "++(show.length.interfaceG) fspec++" interfaces) ***: "+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-interfaceG fspec ]++"\n"+       )++        +       (let ds fs = allDecls fs `uni` allUsedDecls fs `uni` vrels fspec `uni` nub (map qDcl (vquads fs)) in+        if null (ds fspec)     then "" else+        "\n -- *** Declarations (total: "++(show.length.ds) fspec++" declarations) ***: "+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-ds fspec]++"\n"+       ) +++       (if null (vIndices fspec)     then "" else+        "\n -- *** Indices (total: "++(show.length.vIndices) fspec++" indices) ***: "+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vIndices fspec]++"\n"+       ) +++       (if null (vviews fspec)     then "" else+        "\n -- *** Views (total: "++(show.length.vviews) fspec++" views) ***: "+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vviews fspec]++"\n"+       ) +++       (if null (vprocesses fspec ) then "" else+        "\n -- *** Processes (total: "++(show.length.vprocesses) fspec++" processes) ***: "+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vprocesses fspec ]++"\n"+       )+++       (if null (vrules   fspec ) then "" else+        "\n -- *** User defined rules (total: "++(show.length.vrules) fspec++" rules) ***: "+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vrules     fspec ]++"\n"+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-map srrel (vrules fspec)]++"\n"+       )+++       (if null (grules   fspec ) then "" else+        "\n -- *** Generated rules (total: "++(show.length.grules) fspec++" rules) ***: "+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-grules     fspec ]++"\n"+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-map srrel (grules fspec)]++"\n"+       )+++       (if null (vconjs fspec ) then "" else+        "\n -- *** Conjuncts (total: "++(show.length.vconjs) fspec++" conjuncts) ***: "+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vconjs     fspec ]++"\n"+       )+++       (if null (vquads fspec ) then "" else+        "\n -- *** Quads (total: "++(show.length.vquads) fspec++" quads) ***: "+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vquads     fspec ]++"\n"+       )+++       (if null (vEcas fspec ) then "" else+        "\n -- *** ECA rules (total: "++(show.length.vEcas) fspec++" ECA rules) ***: "+++        concat [indent++" "++showHSName eca++indent++"  = "++showHS flags (indent++"    ") eca |eca<-vEcas fspec ]++"\n"+++        concat [indent++" "++showHSName rel++indent++"  = "++showHS flags (indent++"    ") rel |rel<-nub(map ecaDelta (vEcas fspec)) ]++"\n"+       )+++       (if null (plugInfos fspec ) then "" else+        "\n -- *** PlugInfos (total: "++(show.length.plugInfos) fspec++" plugInfos) ***: "+++        concat [indent++" "++showHSName p++indent++"  = "++showHS flags (indent++"    ") p |InternalPlug p<-sortBy (compare `on` name) (plugInfos fspec) ]++"\n"+       )+++       (if null (vpatterns fspec) then "" else+        "\n -- *** Patterns (total: "++(show.length.vpatterns) fspec++" patterns) ***: "+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x |x<-vpatterns fspec]++"\n"+       )+++       (if null (vConceptDefs fspec) then "" else+        "\n -- *** ConceptDefs (total: "++(show.length.vConceptDefs) fspec++" conceptDefs) ***: "+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x | x<-sortBy (comparing showHSName) (vConceptDefs fspec)]++"\n"+       )+++       (if null (allConcepts fspec) then "" else+        "\n -- *** Concepts (total: "++(show.length.allConcepts) fspec++" concepts) ***: "+++        concat [indent++" "++showHSName x++indent++"  = "++showHS flags (indent++"    ") x+             ++ indent++"    "++showAtomsOfConcept x |x<-sortBy (comparing showHSName) (allConcepts fspec)]++"\n"+       )+           where indentA = indent ++"                      "+                 indentB = indent ++"             "+                 showAtomsOfConcept c =+                              "-- atoms: "++(show.sort) (atomsOf (gens fspec)(initialPops fspec) c)+                 showViolatedRule :: String -> (Rule,Pairs) -> String+                 showViolatedRule indent' (r,ps)+                    = intercalate indent'+                        [        " ( "++showHSName r++" -- This is "++(if r_sgl r then "a process rule." else "an invariant")+++                         indent'++" , "++ wrap "" (indent'++"   ") (let showPair _ p = show p --"( "++ (show.fst) p++", "++(show.snd) p++")"+                                                                      in showPair) ps+++                         indent'++" )"+                        ] ++   instance ShowHS Meta where+    showHS f i (Meta pos obj nm val) = "Meta ("++showHS f i pos ++ ") "++ show obj ++ " " ++ show nm ++ " " ++ show val ++-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: PlugInfo   ***+-- \***********************************************************************++   instance ShowHSName PlugInfo where+    showHSName (InternalPlug p) = haskellIdentifier ("ipl_"++name p)-- TODO+    showHSName (ExternalPlug _) = fatal 336 "a PlugInfo is anonymous with respect to showHS flags"++   instance ShowHS PlugInfo where+    showHS _ _ (InternalPlug p)+     = "InternalPlug "++showHSName p+    showHS flags ind (ExternalPlug o)+     = "ExternalPlug "++showHS flags (ind++"    ") o+   +-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: RoleRelation   ***+-- \***********************************************************************++   instance ShowHS RoleRelation where+    showHS flags ind rr+     = "RR "++show (rrRoles rr)++" "++showHS flags (ind++"    ") (rrRels rr)++" "++showHS flags (ind++"    ") (rrPos rr)+   +   instance ShowHS RoleRule where+    showHS flags ind rs+     = "Maintain "++show (mRoles rs)++" "++show (mRules rs)++" "++showHS flags (ind++"    ") (mPos rs)+   ++   instance ShowHSName FSid where+    showHSName (FS_id nm ) = haskellIdentifier nm ++   instance ShowHS FSid where+    showHS _ _ (FS_id nm) +      = "(FS_id " ++ show nm ++ ")"+     +-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: Pattern                       ***+-- \***********************************************************************++   instance ShowHSName Pattern where+    showHSName pat = haskellIdentifier ("pat_"++name pat)+   +   instance ShowHS Pattern where+    showHS flags indent pat+     = intercalate indentA+        [ "A_Pat { ptnm  = "++show (name pat)+        , ", ptpos = "++showHS flags "" (ptpos pat)+        , ", ptend = "++showHS flags "" (ptend pat)+        , ", ptrls = [" ++intercalate ", " [showHSName r | r<-ptrls pat] ++ concat [" {- no rules -} "        | null (ptrls pat)] ++"]"+        , wrap ", ptgns = " indentB (showHS flags) (ptgns pat)+        , ", ptdcs = [" ++intercalate ", " [showHSName d | d<-ptdcs pat] ++ concat [" {- no declarations -} " | null (ptdcs pat)] ++"]"+        , wrap ", ptups = " indentB (showHS flags) (ptups pat) +        , case ptrruls pat of+           []          -> ", ptrruls = [] {- no role-rule assignments -}"+           [(rol,rul)] -> ", ptrruls = [ ("++show rol++", "++showHSName rul++") ]"+           rs          -> ", ptrruls = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHSName rul++")" | (rol,rul)<-rs] ++indentB++"]"+        , case ptrrels pat of+           []          -> ", ptrrels = [] {- no role-relation assignments -}"+           [(rol,rel)] -> ", ptrrels = [ ("++show rol++", "++showHS flags "" rel++") ]"+           rs          -> ", ptrrels = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHS flags "" rel++")" | (rol,rel)<-rs] ++indentB++"]"+        , wrap ", ptids = " indentB (showHS flags) (ptids pat)+        , wrap ", ptxps = " indentB (showHS flags) (ptxps pat)+        , "}"+        ] where indentA = indent ++"      "     -- adding the width of "A_Pat "+                indentB = indentA++"          " -- adding the width of ", ptrls = "++   instance ShowHSName FProcess where+    showHSName prc = haskellIdentifier ("fprc_"++name (fpProc prc))+   +   instance ShowHS FProcess where+    showHS flags indent prc+     = intercalate indentA+        [ "FProc { fpProc       = "++showHS flags (indent++"                     ") (fpProc prc)+        , wrap  ", fpActivities = " indentB (showHS flags) (fpActivities prc)+        , "      }"+        ] where indentA = indent ++"      "     -- adding the width of "FProc "+                indentB = indentA++"                 " -- adding the width of ", fpActivities = "+ +   instance ShowHSName Process where+    showHSName prc = haskellIdentifier ("prc_"++name prc)++   instance ShowHS Process where+    showHS flags indent prc+     = intercalate indentA+        [ "Proc { prcNm = "++show (name prc)+        , ", prcPos = "++showHS flags "" (prcPos prc)+        , ", prcEnd = "++showHS flags "" (prcEnd prc)+        , ", prcRules = [" ++intercalate ", " [showHSName r | r<-prcRules prc] ++ concat [" {- no rules -} "                     | null (prcRules prc)] ++"]"+        , wrap ", prcGens = " indentB (showHS flags) (prcGens prc)+        , ", prcDcls = ["  ++intercalate ", " [showHSName d | d<-prcDcls  prc] ++ concat [" {- no declarations -} "              | null (prcDcls  prc)] ++"]"+        , wrap ", prcUps = " indentB (showHS flags) (prcUps prc) +        , case prcRRuls prc of+           []          -> "     , prcRRuls = [] {- no role-rule assignments -}"+           [(rol,rul)] -> "     , prcRRuls = [ ("++show rol++", "++showHSName rul++") ]"+           rs          -> "     , prcRRuls = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHSName rul++")" | (rol,rul)<-rs] ++indentB++"]"+        , case prcRRels prc of+           []          -> "     , prcRRels = [] {- no role-relation assignments -}"+           [(rol,rel)] -> "     , prcRRels = [ ("++show rol++", "++showHS flags "" rel++") ]"+           rs          -> "     , prcRRels = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHS flags "" rel++")" | (rol,rel)<-rs] ++indentB++"]"+        , wrap ", prcIds = " indentB (showHS flags) (prcIds prc)+        , wrap ", prcVds = " indentB (showHS flags) (prcVds prc)+        , wrap ", prcXps = " indentB (showHS flags) (prcXps prc)+        , "}"+        ] where indentA = indent ++"      "     -- adding the width of "FProc "+                indentB = indentA++"             " -- adding the width of ", prcRules = "++-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: Activity                         ***+-- \***********************************************************************++   instance ShowHS Activity where+    showHS flags indent act = +       intercalate indentA+        [ "Act { actRule   = "++showHSName (actRule act)+        , wrap ", actTrig   = " indentB (showHS flags) (actTrig   act)+        , wrap ", actAffect = " indentB (showHS flags) (actAffect act)+        , wrap ", actQuads  = " indentB (\_->showHSName) (actQuads  act)+        , wrap ", actEcas   = " indentB (\_->showHSName) (actEcas   act)+        , wrap ", actPurp   = " indentB (\_->(showHS flags indentB)) (actPurp act)+        , "      }"+        ]+       where indentA = indent ++replicate (length "Act "          ) ' ' +             indentB = indentA++replicate (length ", actAffect = ") ' '++   instance ShowHS PPurpose where+    showHS flags _ expla = +       "PRef2 ("++showHS flags "" (pexPos     expla)++") "+++             "("++showHS flags "" (pexObj     expla)++") "+++             "("++showHS flags "" (pexMarkup  expla)++") "+                ++show (pexRefID expla)++" "+                +   instance ShowHS PRef2Obj where+    showHS _ _ peObj+     = case peObj of +            PRef2ConceptDef str               -> "PRef2ConceptDef " ++show str+            PRef2Declaration (PTrel _ nm sgn) -> "PRef2Declaration "++show nm++show sgn+            PRef2Declaration (Prel _ nm)      -> "PRef2Declaration "++show nm+            PRef2Declaration expr             -> fatal 583 ("Expression "++show expr++" should never occur in PRef2Declaration")+            PRef2Rule str                     -> "PRef2Rule "       ++show str+            PRef2IdentityDef str              -> "PRef2IdentityDef "++show str+            PRef2ViewDef str                  -> "PRef2ViewDef "    ++show str+            PRef2Pattern str                  -> "PRef2Pattern "    ++show str+            PRef2Process str                  -> "PRef2Process "    ++show str+            PRef2Interface str                -> "PRef2Interface "  ++show str+            PRef2Context str                  -> "PRef2Context "    ++show str+            PRef2Fspc str                     -> "PRef2Fspc "       ++show str+                           +   instance ShowHS Purpose where+    showHS flags _ expla = +       "Expl "++"("++showHS flags "" (explPos expla)++") "+              ++"("++showHS flags "" (explObj expla)++") "+                   ++showHS flags "" (explMarkup  expla)++" "+                   ++show (explUserdefd expla)++" "+                   ++show (explRefId expla)++" "++   instance ShowHS ExplObj where+    showHS _ {-flags-} _ {-i-} peObj = case peObj of                     -- SJ: names of variables commented out to prevent warnings.+             ExplConceptDef cd  -> "ExplConceptDef " ++showHSName cd+             ExplDeclaration d  -> "ExplDeclaration "++showHSName d+             ExplRule str       -> "ExplRule "       ++show str+             ExplIdentityDef str-> "ExplIdentityDef "++show str+             ExplViewDef str    -> "ExplViewDef "    ++show str+             ExplPattern str    -> "ExplPattern "    ++show str+             ExplProcess str    -> "ExplProcess "    ++show str+             ExplInterface str  -> "ExplInterface "  ++show str+             ExplContext str    -> "ExplContext "    ++show str+           +   instance ShowHS P_Markup where+    showHS _ indent m+      = intercalate indent +        ["P_Markup{ mLang   = "++ show (mLang m)+        ,"        , mFormat = "++ show (mFormat m)+        ,"        , mString = "++ show (mString m)+        ,"        }"+        ]++   instance ShowHS A_Markup where+    showHS _ indent m+      = intercalate indent +        ["A_Markup{ amLang   = "++ show (amLang m)+        ,"        , amFormat = "++ show (amFormat m)+        ,"        , amPandoc = "++ show (amPandoc m)+        ,"        }"+        ]+-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: PairView                      ***+-- \***********************************************************************++   instance ShowHS (PairView Expression) where+     showHS flags indent (PairView pvs) = "PairView "++showHS flags indent pvs+     +   instance ShowHS (PairViewSegment Expression) where+     showHS _     _ (PairViewText txt) = "PairViewText "++show txt+     showHS flags _ (PairViewExp srcOrTgt e) = "PairViewExp "++show srcOrTgt++" ("++showHS flags "" e++")"++-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: Rule                          ***+-- \***********************************************************************++   instance ShowHSName Rule where+    showHSName r = haskellIdentifier ("rule_"++ rrnm r)++   instance ShowHS Rule where+    showHS flags indent r@(Ru _ _ _ _ _ _ _ _ _ _ _ _)  -- This pattern matching occurs so Haskell will detect any change in the definition of Ru.+      = intercalate indent +        ["Ru{ rrnm   = " ++ show (rrnm   r)+        ,"  , rrexp  = " ++ showHS flags (indent++"             ") (rrexp  r)+        ,"  , rrfps  = " ++ showHS flags "" (rrfps  r)+        ,"  , rrmean = " ++ showHS flags "" (rrmean r)+        ,"  , rrmsg  = " ++ showHS flags "" (rrmsg  r)+        ,"  , rrviol = " ++ showHS flags "" (rrviol r)+        ,"  , rrtyp  = " ++ showHS flags "" (rrtyp  r)+        ,"  , rrdcl  = " ++ case rrdcl r of+                              Just (p,d) -> "Just ("++showHSName p++", "++showHSName d++" )"+                              Nothing    -> "Nothing"+        ,"  , r_env  = " ++ show (r_env  r)+        ,"  , r_usr  = " ++ show (r_usr  r)+        ,"  , r_sgl  = " ++ show (r_sgl  r)+        ,"  , srrel  = " ++ showHSName (srrel  r)+        ,"  }"+        ]++   instance ShowHS AMeaning where+     showHS flags indent (AMeaning x) = "AMeaning " ++ showHS flags indent x ++-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: RuleType                      ***+-- \***********************************************************************+   instance ShowHS RuleType where+     showHS _ _ Truth          = "Truth"+     showHS _ _ Equivalence    = "Equivalence"+     showHS _ _ Implication    = "Implication"+   +-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: IdentityDef                        ***+-- \***********************************************************************++   instance ShowHSName IdentityDef where+    showHSName identity = haskellIdentifier ("identity_"++name identity)+   +   instance ShowHS IdentityDef where+    showHS flags indent identity+     = "Id ("++showHS flags "" (idPos identity)++") "++show (idLbl identity)++" ("++showHSName (idCpt identity)++")"+       ++indent++"  [ "++intercalate (indent++"  , ") (map (showHS flags indent) $ identityAts identity)++indent++"  ]"+   +-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: IdentitySegment                        ***+-- \***********************************************************************++   --instance ShowHSName IdentitySegment where+   -- showHSName identitySeg = haskellIdentifier ("identitySegment_"++name identitySeg)+   +   instance ShowHS IdentitySegment where+    showHS flags indent (IdentityExp objDef) = "IdentityExp ("++ showHS flags indent objDef ++ ")"++-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: ViewDef                        ***+-- \***********************************************************************++   instance ShowHSName ViewDef where+    showHSName vd = haskellIdentifier ("vdef_"++name vd)+   +   instance ShowHS ViewDef where+    showHS flags indent vd+     = "Vd ("++showHS flags "" (vdpos vd)++") "++show (vdlbl vd)++" ("++showHSName (vdcpt vd)++")"+       ++indent++"  [ "++intercalate (indent++"  , ") (map (showHS flags indent) $ vdats vd)++indent++"  ]"+   +-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: ViewSegment                        ***+-- \***********************************************************************++   --instance ShowHSName ViewSegment where+   -- showHSName vd = haskellIdentifier ("vdef_"++name vd)+   +   instance ShowHS ViewSegment where+    showHS _     _      (ViewText str) = "ViewText "++show str+    showHS _     _      (ViewHtml str) = "ViewHtml "++show str+    showHS flags indent (ViewExp objDef) = "ViewExp ("++ showHS flags indent objDef ++ ")"+   +   instance ShowHS Population where+    showHS _ indent pop+     = case pop of +         PRelPopu{} -> "PRelPopu { popdcl = "++showHSName (popdcl pop)+             ++indent++"         , popps  = [ "++intercalate +              (indent++"                    , ") (map show (popps pop))+             ++indent++"                    ]"+             ++indent++"         }"+         PCptPopu{} -> "PCptPopu { popcpt = "++showHSName (popcpt pop)+             ++indent++"         , popas  = [ "++intercalate+              (indent++"                    , ") (map show (popas pop))+             ++indent++"                    ]"+             ++indent++"         }"+   +   instance ShowHSName ObjectDef where+    showHSName obj = haskellIdentifier ("oDef_"++name obj)++   instance ShowHS ObjectDef where+    showHS flags indent r +     = intercalate indent+           ["Obj{ objnm   = " ++ show(objnm r)+           ,"   , objpos  = " ++ showHS flags "" (objpos r)  +           ,"   , objctx  = " ++ showHS flags (indent++"               ") (objctx r)+           ,"   , objmsub = " ++ showHS flags (indent++"                    ") (objmsub r)+           ,"   , objstrs = " ++ show(objstrs r)+           ]++indent++"   }"++   instance ShowHSName Interface where+    showHSName obj = haskellIdentifier ("ifc_"++name obj)+   +   instance ShowHS Interface where+    showHS flags indent ifc+     = intercalate indent +           [ wrap "Ifc { ifcParams = " (indent++"                  ") (showHS flags) (ifcParams ifc)+           , "    , ifcArgs   = " ++ show(ifcArgs ifc)+           , "    , ifcRoles  = " ++ show(ifcRoles ifc)+           , "    , ifcObj"++indent++"       = " ++ showHS flags (indent++"         ") (ifcObj ifc)+           , "    , ifcPos    = " ++ showHS flags "" (ifcPos ifc)+           , "    , ifcPrp    = " ++ show(ifcPrp ifc)+           ]++indent++"    }"++   instance ShowHS SubInterface where+    showHS _     _      (InterfaceRef n) = "InterfaceRef "++show n +    showHS flags indent (Box x objs) = "Box ("++showHS flags indent x++")"++indent++"     ("++showHS flags (indent++"     ") objs++")" ++   instance ShowHS Expression where+    showHS flags indent (EEqu (l,r)) = "EEqu ("++showHS flags (indent++"       ") l++indent++"     , "++showHS flags (indent++"       ") r++indent++"     )"+    showHS flags indent (EImp (l,r)) = "EImp ("++showHS flags (indent++"       ") l++indent++"     , "++showHS flags (indent++"       ") r++indent++"     )"+    showHS flags indent (EIsc (l,r)) = "EIsc ("++showHS flags (indent++"       ") l++indent++"     , "++showHS flags (indent++"       ") r++indent++"     )"+    showHS flags indent (EUni (l,r)) = "EUni ("++showHS flags (indent++"       ") l++indent++"     , "++showHS flags (indent++"       ") r++indent++"     )"+    showHS flags indent (EDif (l,r)) = "EDif ("++showHS flags (indent++"       ") l++indent++"     , "++showHS flags (indent++"       ") r++indent++"     )"+    showHS flags indent (ELrs (l,r)) = "ELrs ("++showHS flags (indent++"       ") l++indent++"     , "++showHS flags (indent++"       ") r++indent++"     )"+    showHS flags indent (ERrs (l,r)) = "ERrs ("++showHS flags (indent++"       ") l++indent++"     , "++showHS flags (indent++"       ") r++indent++"     )"+    showHS flags indent (ECps (l,r)) = "ECps ("++showHS flags (indent++"       ") l++indent++"     , "++showHS flags (indent++"       ") r++indent++"     )"+    showHS flags indent (ERad (l,r)) = "ERad ("++showHS flags (indent++"       ") l++indent++"     , "++showHS flags (indent++"       ") r++indent++"     )"+    showHS flags indent (EPrd (l,r)) = "EPrd ("++showHS flags (indent++"       ") l++indent++"     , "++showHS flags (indent++"       ") r++indent++"     )"+    showHS flags indent (EKl0 e    ) = "EKl0 ("++showHS flags (indent++"      ") e++")"+    showHS flags indent (EKl1 e    ) = "EKl1 ("++showHS flags (indent++"      ") e++")"+    showHS flags indent (EFlp e    ) = "EFlp ("++showHS flags (indent++"      ") e++")"+    showHS flags indent (ECpl e    ) = "ECpl ("++showHS flags (indent++"      ") e++")"+    showHS flags indent (EBrk e    ) = "EBrk ("++showHS flags (indent++"      ") e++")"+    showHS _     _      (EDcD dcl  ) = "EDcD "++showHSName dcl+    showHS _     _      (EDcI c    ) = "EDcI "++showHSName c+    showHS flags _      (EEps i sgn) = "EEps ("++showHS flags "" i++") ("++showHS flags "" sgn++")"+    showHS flags _      (EDcV sgn  ) = "EDcV ("++showHS flags "" sgn++")"+    showHS _     _      (EMp1 a c  ) = "EMp1 ("++show a++") "++showHSName c++-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: Sign                           ***+-- \***********************************************************************++   instance ShowHS Sign where+    showHS _ _ sgn = "Sign "++showHSName (source sgn)++" "++showHSName (target sgn)+   +-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: Isa                           ***+-- \***********************************************************************++   instance ShowHS A_Gen where+    showHS flags _ gen@Isa{} = "Isa ("++showHS flags "" (genfp gen)++") ("++showHSName (gengen gen)++") ("++showHSName (genspc gen)++") "+    showHS flags _ gen@IsE{} = "IsE ("++showHS flags "" (genfp gen)++") ["++intercalate ", " (map showHSName (genrhs gen))++"] ("++showHSName (genspc gen)++") "+   +   instance ShowHSName Declaration where+    showHSName d@Isn{}       = haskellIdentifier ("rel_"++name d++"_"++name (source d)) -- identity relation+    showHSName d@Vs{}        = haskellIdentifier ("rel_"++name d++"_"++name (source d)++name (target d)) -- full relation+    showHSName d | decusr d  = haskellIdentifier ("rel_"++name d++name (source d)++name (target d)) -- user defined relations+                 | deciss d  = haskellIdentifier ("sgn_"++name d++name (source d)++name (target d)) -- relations generated for signalling+                 | otherwise = haskellIdentifier ("vio_"++name d++name (source d)++name (target d)) -- relations generated per rule+   +   instance ShowHS Declaration where+    showHS flags indent d +       = case d of +          Sgn{}     -> intercalate indent+                        ["Sgn{ decnm   = " ++ show (decnm d)+                        ,"   , decsgn  = " ++ showHS flags "" (sign d)+                        ,"   , decprps = " ++ showL(map (showHS flags "") (decprps d))+                        ,"   , decprps_calc = " ++ case decprps_calc d of+                                                    Nothing -> "Nothing"+                                                    Just ps -> "Just "++showL(map (showHS flags "") ps)+                        ,"   , decprL  = " ++ show (decprL d)+                        ,"   , decprM  = " ++ show (decprM d)+                        ,"   , decprR  = " ++ show (decprR d)+                        ,"   , decMean = " ++ show (decMean d)+                        ,"   , decConceptDef = " ++ show (decConceptDef d)+                        ,"   , decfpos = " ++ showHS flags "" (decfpos d)+                        ,"   , decissX = " ++ show (deciss d)+                        ,"   , decusrX = " ++ show (decusr d)+                        ,"   , decISA  = " ++ show (decISA d)+                        ,"   , decpat  = " ++ show (decpat d)+                        ,"   , decplug = " ++ show (decplug d)+                        ]++"}"+          Isn{}     -> "Isn{ detyp   = " ++ showHSName (detyp d)++"}"+          Vs{}      -> "Vs { decsgn  = " ++ showHS flags "" (sign d)++"}"++-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: ConceptDef                    ***+-- \***********************************************************************++   instance ShowHSName ConceptDef where+    showHSName cd = haskellIdentifier ("cDef_"++cdcpt cd)++   instance ShowHS ConceptDef where+    showHS flags _ cd+     = " Cd ("++showHS flags "" (cdpos cd)++") "++show (cdcpt cd)++" "++show (cdplug cd)++" "++show (cddef cd)++" "++show (cdtyp cd)++" "++show (cdref cd)++-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: Concept                     ***+-- \***********************************************************************+   instance ShowHSName A_Concept where+    showHSName ONE = haskellIdentifier "cptOne"+    showHSName c = haskellIdentifier ("cpt_"++name c) +   instance ShowHS A_Concept where+    showHS _ _ c = case c of+                       PlainConcept{} -> "PlainConcept "++show (name c) ++ " "++ show (cpttp c) ++ " ["++intercalate ", " (map showHSName (cptdf c))++"]"+                       ONE -> "ONE"++   instance ShowHS FPcompl where+    showHS _ _   = show++   instance ShowHS FPA where+    showHS _ _ (FPA t c) = "FPA "++show t++" "++show c+   +   instance ShowHSName Prop where+    showHSName Uni = "Uni"+    showHSName Inj = "Inj"+    showHSName Sur = "Sur"+    showHSName Tot = "Tot"+    showHSName Sym = "Sym"+    showHSName Asy = "Asy"+    showHSName Trn = "Trn"+    showHSName Rfx = "Rfx"+    showHSName Irf = "Irf"++   instance ShowHS Prop where+    showHS _ _ = showHSName+    +   instance ShowHS FilePos where+    showHS _ _ (FilePos (fn,DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.Pos l c,sym))+      = "FilePos ("++show fn++",Pos "++show l++" "++show c++","++show sym++")"++   instance ShowHSName Origin where+    showHSName ori = "Orig"++show x++show (hash x)+      where x = case ori of+                 FileLoc l -> "FileLoc (" ++ show l++")"+                 DBLoc l   -> "DBLoc " ++ show l+                 Origin s  -> "Origin " ++ show s+                 OriginUnknown -> "OriginUnknown"+                 SomewhereNear s -> "SomewhereNear "++show s+   +   instance ShowHS Origin where+    showHS flags indent (FileLoc l) = "FileLoc (" ++ showHS flags indent l++")"+    showHS _ _ (DBLoc l) = "DBLoc " ++ show l+    showHS _ _ (Origin s) = "Origin " ++ show s+    showHS _ _ OriginUnknown+      = "OriginUnknown"+    showHS _ _ (SomewhereNear s) +      = "SomewhereNear "++show s+++-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: Block                         ***+-- \***********************************************************************++   instance ShowHS Block where+    showHS _ _   = show++-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: Inline                        ***+-- \***********************************************************************++   instance ShowHS Inline where+    showHS _ _   = show++-- \***********************************************************************+-- \*** Eigenschappen met betrekking tot: InfTree                       ***+-- \***********************************************************************+--   instance ShowHS InfTree where+--    showHS flags indent itree =+--        case itree of+--          InfExprs irt (ratype,raobj) itrees -> +--              "InfExprs " ++ showHS flags indent irt ++ +--              indent ++ "   (" ++ showRaType ratype ++ "," ++ "RelAlgObj{-"++show raobj++"-}" ++ ")" +++--              indent ++ showHS flags (indent ++ "     ") itrees+--          InfRel drt ratype _ _ -> +--              "InfRel " ++ showHS flags indent drt ++ " " ++ showRaType ratype+--      where +--       showRaType rat = "RelAlgType{-"++show rat++"-}"+--+--   instance ShowHS RelDecl where+--    showHS _ indent d = case d of +--                          RelDecl{}-> "RelDecl{ dname  = " ++ show (dname d) ++ indent+--                                   ++ "        ,dtype  = " ++ showRaType dtype ++ indent+--                                   ++ "        ,isendo = " ++ show (isendo d) +--                          IDecl    -> "IDecl"+--                          VDecl    -> "VDecl"+--      where +--       showRaType _ = "RelAlgType{- ++TODO++ -}"+--+--+--   instance ShowHS DeclRuleType where+--    showHS _ _ drt = case drt of+--                                         D_rel     -> "D_rel"+--                                         D_rel_h   -> "D_rel_h"+--                                         D_rel_c   -> "D_rel_c"+--                                         D_rel_c_h -> "D_rel_c_h"+--                                         D_id      -> "D_id"+--                                         D_v       -> "D_v"+--                                         D_id_c    -> "D_id_c"+--                                         D_v_c     -> "D_v_c"+--                        +--   instance ShowHS InfRuleType where+--    showHS _ _ irt = case irt of+--                                         ISect_cs  -> "ISect_cs"+--                                         ISect_ncs -> "ISect_ncs"+--                                         ISect_mix -> "ISect_mix"+--                                         Union_mix -> "Union_mix"+--                                         Comp_ncs  -> "Comp_ncs"+--                                         Comp_c1   -> "Comp_c1"+--                                         Comp_c2   -> "Comp_c2"+--                                         Comp_cs   -> "Comp_cs"+--                                         RAdd_ncs  -> "RAdd_ncs"+--                                         RAdd_c1   -> "RAdd_c1"+--                                         RAdd_c2   -> "RAdd_c2"+--                                         RAdd_cs   -> "RAdd_cs"+--                                         Conv_nc   -> "Conv_nc"+--                                         Conv_c    -> "Conv_c"+                                           +-- \***********************************************************************+-- \*** hulpfuncties                                                    ***+-- \***********************************************************************++   haskellIdentifier :: String -> String+   haskellIdentifier cs = unCap (hsId cs)+    where+      hsId ('_': cs')             = '_': hsId cs'+      hsId (c:cs') | isAlphaNum c = c: hsId cs'+                   | otherwise    = hsId cs'+      hsId ""                     = ""++   showL :: [String] -> String+   showL xs = "["++intercalate "," xs++"]"++
+ src/lib/DatabaseDesign/Ampersand/Fspec/ShowMeatGrinder.hs view
@@ -0,0 +1,303 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-} 
+module DatabaseDesign.Ampersand.Fspec.ShowMeatGrinder 
+  (meatGrinder)
+where
+
+import Data.List
+import Data.Ord
+import DatabaseDesign.Ampersand.Fspec.Fspec
+import DatabaseDesign.Ampersand.Fspec.Motivations
+import DatabaseDesign.Ampersand.Basics
+import DatabaseDesign.Ampersand.Misc
+import DatabaseDesign.Ampersand.Fspec.ShowADL
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+import Data.Hashable
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Fspec.ShowMeatGrinder"
+
+meatGrinder :: Options -> Fspc -> (FilePath, String)
+meatGrinder flags fSpec = ("TemporaryPopulationsFileOfRap" ,content)
+ where 
+  content = unlines
+     ([ "{- Do not edit manually. This code has been generated!!!"
+      , "    Generated with "++ampersandVersionStr
+      , "    Generated at "++show (genTime flags)
+      , "-}"
+      , ""
+      , "CONTEXT RapPopulations"]
+      ++ (concat.intersperse  []) (map (lines.showADL) (metaPops flags fSpec fSpec)) 
+      ++
+      [ ""
+      , "ENDCONTEXT"
+      ])
+data Pop = Pop { popName ::String
+               , popSource :: String
+               , popTarget :: String
+               , popPairs :: [(String,String)]
+               } 
+         | Comment { comment :: String  -- Not-so-nice way to get comments in a list of populations. Since it is local to this module, it is not so bad, I guess...
+                   } 
+instance ShowADL Pop where
+ showADL pop = 
+  case pop of
+      Pop{} -> "POPULATION "++ popName pop++
+                  " ["++popSource pop++" * "++popTarget pop++"] CONTAINS"
+              ++
+              if null (popPairs pop)
+              then "[]" 
+              else "\n"++indent++"[ "++intercalate ("\n"++indent++"; ") showContent++indent++"]"
+      Comment{} -> "-- "++comment pop        
+    where indent = "   "
+          showContent = map showPaire (popPairs pop)
+          showPaire (s,t) = "( "++show s++" , "++show t++" )"
+
+
+techId :: Identified a => a -> String
+techId = show.hash.name
+class AdlId a where
+ uri :: a -> String
+
+instance AdlId Fspc where 
+ uri a= "Ctx"++techId a
+instance AdlId Pattern where 
+ uri a= "Pat"++techId a
+instance AdlId A_Concept where 
+ uri a= "Cpt"++techId a
+instance AdlId ConceptDef where 
+ uri a= "CDf"++techId a
+instance AdlId Rule where 
+ uri a= "Rul"++techId a
+instance AdlId A_Gen where 
+ uri a= "Isa"++(show.hash) g
+        where g = case a of
+                    Isa{} -> ((name.gengen) a++(name.genspc) a)
+                    IsE{} -> ((concat.map name.genrhs) a++(name.genspc) a)
+instance AdlId Declaration where 
+ uri a= "Dcl"++techId a
+instance AdlId Purpose where 
+ uri a= "Prp"++(show.hash)((show.origin) a)
+instance AdlId Sign where 
+ uri (Sign s t) = "Sgn"++(show.hash) (uri s++uri t)
+ 
+data RelPopuType = InitPop | CurrPop deriving Show
+mkUriRelPopu :: Declaration -> RelPopuType  -> String
+mkUriRelPopu d t = show t++"Of"++uri d
+
+data Atom = Atom { atmRoot :: A_Concept -- The root concept of the atom. (this implies that there can only be a single root for
+                 , atmVal :: String
+                 } deriving Eq
+instance AdlId Atom where
+ uri a="Atm"++atmVal a++"Of"++(uri.atmRoot) a  
+
+
+mkAtom :: A_Concept -> String -> Atom
+mkAtom cpt value = Atom { atmRoot = cpt -- Was: root cpt.  <SJ 20131117> Han, "root cpt" cannot be correct in this spot. I am quite sure that "cpt" is correct. Please confer.
+                        , atmVal  = value
+                        }
+
+class MetaPopulations a where
+ metaPops :: Options -> Fspc -> a -> [Pop]
+
+instance MetaPopulations Fspc where
+ metaPops flags _ fSpec = 
+   filter (not.nullContent)
+    (
+    [ Comment " "
+    , Comment "The following declarations are all known declarations. This list should be"
+    , Comment "helpfull during the developement of the meatgrinder."
+    , Comment "NOTE:"
+    , Comment "  The order of the declarations is determined in a special way, based on Concepts."
+    ]
+  ++[Comment ("  "++show i++") "++"Pop "++(show.name) dcl++" "++(show.name.source) dcl++" "++(show.name.target) dcl) | (i,dcl) <- (declOrder.allDecls)       fSpec]
+  ++[ Pop "ctxnm"   "Context" "Conid"
+           [(uri fSpec,name fSpec)]
+    ]
+  ++[ Comment " ", Comment $ "*** Patterns: (count="++(show.length.vpatterns) fSpec++") ***"]
+  ++   concat [metaPops flags fSpec pat | pat <- (sortBy (comparing name).vpatterns  )    fSpec]
+  ++[ Comment " ", Comment $ "*** Rules: (count="++(show.length.allRules) fSpec++")***"]
+  ++   concat [metaPops flags fSpec rul | rul <- (sortBy (comparing name).allRules)    fSpec]
+
+
+  ++[ Comment " ", Comment $ "*** Concepts: (count="++(show.length.allConcepts) fSpec++")***"]
+  ++   concat [metaPops flags fSpec cpt | cpt <- (sortBy (comparing name).allConcepts)    fSpec]
+  ++[ Comment " ", Comment $ "*** Generalisations: (count="++(show.length.vgens) fSpec++") ***"]
+  ++   concat [metaPops flags fSpec gen | gen <- vgens          fSpec]
+  ++[ Comment " ", Comment $ "*** Declarations: (count="++(show.length.allDecls) fSpec++") ***"]
+  ++   concat [metaPops flags fSpec dcl | (_,dcl) <- (declOrder.allDecls)       fSpec]
+  ++[ Comment " ", Comment $ "*** Atoms: ***"]
+  ++   concat [metaPops flags fSpec atm | atm <- allAtoms]
+  )
+   where
+    allAtoms :: [Atom]
+    allAtoms = nub (concatMap atoms (initialPops fSpec))
+      where 
+        atoms :: Population -> [Atom]
+        atoms udp = case udp of
+          PRelPopu{} ->  map (mkAtom ((source.popdcl) udp).fst) (popps udp) 
+                      ++ map (mkAtom ((target.popdcl) udp).snd) (popps udp) 
+          PCptPopu{} ->  map (mkAtom (        popcpt  udp)    ) (popas udp)
+    nullContent :: Pop -> Bool
+    nullContent (Pop _ _ _ []) = True
+    nullContent _ = False
+    -- | the order of declarations is done by an order of the concepts, which is a hardcoded list 
+    declOrder ::[Declaration] -> [(Int,Declaration)]
+    declOrder decls = zip [1..] (concat (map (sortBy f) (declGroups conceptOrder decls))) 
+      where 
+        conceptOrder = ["Pattern"
+                       ,"Rule"
+                       ,"Declaration"
+                       ,"RelPopu"
+                       ,"A_Concept"
+                       ,"Concept"
+                       ]
+        f a b =
+          case comparing (name.source) a b of
+            EQ -> case comparing (name.target) a b of
+                    EQ -> comparing (name) a b 
+                    x  -> x
+            x -> x
+        declGroups :: [String] -> [Declaration] -> [[Declaration]]
+        declGroups [] ds = [ds]
+        declGroups (nm:nms) ds = [x] ++ declGroups nms y
+           where
+             (x,y) = partition crit ds
+             crit dcl = or [(name.source) dcl == nm, (name.target) dcl == nm]
+instance MetaPopulations Pattern where
+ metaPops _ fSpec pat = 
+   [ Comment " "
+   , Comment $ "*** Pattern `"++name pat++"` ***"
+   , Pop "ctxpats" "Context" "Pattern"
+          [(uri fSpec,uri pat)]
+   , Pop "ptxps"   "Pattern" "Blob"
+          [(uri pat,uri x) | x <- ptxps pat]
+   , Pop "ptnm"    "Pattern" "Conid"
+          [(uri pat, ptnm pat)]
+   , Pop "ptctx" "Pattern" "Context"
+          [(uri pat,uri fSpec)]
+   , Pop "ptdcs"   "Pattern" "Declaration"
+          [(uri pat,uri x) | x <- ptdcs pat]
+   , Pop "ptgns"   "Pattern" "Isa"
+          [(uri pat,uri x) | x <- ptgns pat]
+--HJO, 20130728: TODO: De Image (Picture) van het pattern moet worden gegenereerd op een of andere manier:
+--   , Pop "ptpic"   "Pattern" "Image"
+--          [(uri pat,uri x) | x <- ptpic pat]
+   , Pop "ptrls"   "Pattern" "Rule"
+          [(uri pat,uri x) | x <- ptrls pat]
+   ]
+instance MetaPopulations Rule where
+ metaPops _ fSpec rul =
+   [ Comment " "
+   , Comment $ "*** Rule `"++name rul++"` ***"
+   , Pop "rrnm"  "Rule" "ADLid"
+          [(uri rul,rrnm rul)]
+   , Pop "rrmean"  "Rule" "Blob"
+          [(uri rul,show(rrmean rul))]
+   , Pop "rrpurpose"  "Rule" "Blob"
+          [(uri rul,showADL x) | x <- explanations rul]
+   , Pop "rrexp"  "Rule" "ExpressionID"
+          [(uri rul,showADL (rrexp rul))]
+--HJO, 20130728: TODO: De Image (Picture) van de rule moet worden gegenereerd op een of andere manier:
+--   , Pop "rrpic"   "Rule" "Image"
+--          [(uri rul,uri x) | x <- rrpic pat]
+   , Pop "rrviols"  "Rule" "Violation"
+          [(uri rul,show v) | (r,v) <- allViolations fSpec, r == rul]
+
+   ]
+instance MetaPopulations Declaration where
+ metaPops _ fSpec dcl = 
+   case dcl of 
+     Sgn{} ->
+      [ Comment " "
+      , Comment $ "*** Declaration `"++name dcl++" ["++(name.source.decsgn) dcl++" * "++(name.target.decsgn) dcl++"]"++"` ***"
+      , Pop "decmean"    "Declaration" "Blob"
+             [(uri dcl, show(decMean dcl))]
+      , Pop "decpurpose" "Declaration" "Blob"
+             [(uri dcl, showADL x) | x <- explanations dcl]
+      , Pop "decexample"    "Declaration" "PragmaSentence"
+             [(uri dcl, unwords ["PRAGMA",show (decprL dcl),show (decprM dcl),show (decprR dcl)])]
+      , Pop "decprps" "Declaration" "PropertyRule"
+             [(uri dcl, uri rul) | rul <- filter ofDecl (allRules fSpec)]
+      , Pop "decpopu" "Declaration" "RelPopu"
+             [(uri dcl,mkUriRelPopu dcl CurrPop)] 
+      , Pop "inipopu" "Declaration" "RelPopu"
+             [(uri dcl,mkUriRelPopu dcl InitPop)] 
+      , Pop "decsgn" "Declaration" "Sign"
+             [(uri dcl,uri (decsgn dcl))]
+      , Pop "decprL" "Declaration" "String"
+             [(uri dcl,decprL dcl)]
+      , Pop "decprM" "Declaration" "String"
+             [(uri dcl,decprM dcl)]
+      , Pop "decprR" "Declaration" "String"
+             [(uri dcl,decprR dcl)]
+      , Pop "decnm" "Declaration" "Varid"
+             [(uri dcl, name dcl)]
+ --TODO HIER GEBLEVEN. (HJO, 20130802)
+
+--      , Pop "rels" "ExpressionID" "Declaration"
+--      , Pop "popdcl" "RelPopu" "Declaration"
+
+
+ 
+      ] 
+             
+     Isn{} -> fatal 157 "Isn is not implemented yet"
+     Vs{}  -> fatal 158 "Vs is not implemented yet"
+    where
+      ofDecl :: Rule -> Bool
+      ofDecl rul = case rrdcl rul of
+                     Nothing -> False
+                     Just (_,d) -> d == dcl   
+instance MetaPopulations Atom where
+ metaPops _ _ atm = 
+   [ Pop "root"  "Atom" "Concept"
+          [(uri atm,uri(atmRoot atm))]
+   , Pop "atomvalue"  "Atom" "AtomValue"
+          [(uri atm,atmVal atm)]
+   ]
+   
+instance MetaPopulations A_Gen where
+ metaPops _ _ gen@Isa{} =
+   [ Pop "gengen"  "Isa" "Concept"
+          [(uri gen,uri(gengen gen))]
+   , Pop "genspc"  "Isa" "Concept"
+          [(uri gen,uri(genspc gen))]
+   ]
+ metaPops _ _ gen@IsE{} =
+   [ Pop "genrhs"  "Isa" "Concept"
+          [(uri gen,uri c) | c<-genrhs gen]
+   , Pop "genspc"  "Isa" "Concept"
+          [(uri gen,uri (genspc gen))]
+   ]
+instance MetaPopulations A_Concept where
+ metaPops _ fSpec cpt = 
+   case cpt of
+     PlainConcept{} ->
+      [ Comment " "
+      , Comment $ "*** Concept `"++name cpt++"` ***"
+      , Pop "ctxcs"   "Context" "Concept"
+           [(uri fSpec,uri cpt)]
+      , Pop "cptnm"      "PlainConcept" "Conid"
+             [(uri cpt, name cpt)]
+      , Pop "context"    "PlainConcept" "Context"
+             [(uri cpt,uri fSpec)]
+      , Pop "cpttp"      "PlainConcept" "Blob"
+             [(uri cpt,cpttp cpt) ]
+      , Pop "cptdf"      "PlainConcept" "Blob"
+             [(uri cpt,showADL x) | x <- cptdf cpt]
+--      , Pop "cptpurpose" "PlainConcept" "Blob"
+--             [(uri cpt,showADL x) | x <- purposeOf fSpec cpt ]
+      ]
+     ONE -> [
+            ]
+instance MetaPopulations Sign where
+ metaPops _ _ sgn = 
+      [ Pop "src"    "Sign" "Concept"
+             [(uri sgn, uri (source sgn))]
+      , Pop "trg"   "Sign" "Concept"
+             [(uri sgn, uri (target sgn))]
+      ]
+
+
+ src/lib/DatabaseDesign/Ampersand/Fspec/ShowXMLtiny.hs view
@@ -0,0 +1,330 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+module DatabaseDesign.Ampersand.Fspec.ShowXMLtiny (showXML)
+where
+
+-- TODO: Als het Ampersand bestand strings bevat met speciale characters als '&' en '"', dan wordt nu nog foute XML-code gegenereerd...
+
+   import DatabaseDesign.Ampersand.ADL1
+--   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+   import DatabaseDesign.Ampersand.Classes
+   import DatabaseDesign.Ampersand.Fspec.ShowADL 
+   import DatabaseDesign.Ampersand.Basics
+   import DatabaseDesign.Ampersand.Fspec.Fspec
+   import Data.Time.LocalTime
+   import DatabaseDesign.Ampersand.Fspec.Plug 
+   import DatabaseDesign.Ampersand.Misc.TinyXML 
+   
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Fspec.ShowXMLtiny"
+
+   showXML :: Fspc -> LocalTime -> String
+   showXML fSpec now 
+            = validXML 
+               ("<?xml version=\"1.0\" encoding=\"utf-8\"?>" ++
+                "<tns:ADL xmlns:tns=\"http://ampersand.sourceforge.net/ADL\" "++
+                "xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" "++
+                "xsi:schemaLocation=\"http://ampersand.sourceforge.net/AdlDocs "++
+                "ADL.xsd \">"++
+                "<!-- Generated with "++ ampersandVersionStr ++", at "++ show now ++" -->" ++
+                "<!-- Warning: The format of this generated xml document is subject to changes, and it"++
+                " isn't very stable. Please notify the developers of Ampersand if you have specific needs. -->")
+              ++
+              showXTree ( mkXmlTree fSpec) ++
+              "</tns:ADL>"   
+
+   nameToAttr :: Identified x => x -> XAtt 
+   nameToAttr x = mkAttr "name" (name x)
+
+   ----------------------------------------------------------------------
+  
+   class XML a where 
+    mkTag :: a -> XTag
+    mkXmlTree :: a -> XTree
+   
+   still2bdone :: String -> XTree
+   still2bdone worktxt = Node (Tag "NotImplementedYet" [mkAttr "work2do_in_ShowXML.hs"  worktxt])     
+
+
+   instance XML Fspc where
+     mkTag f = Tag "Fspec" [nameToAttr f] 
+     mkXmlTree f@Fspc{}
+        = Elem (mkTag f) ( 
+             []
+--          ++ [ Elem (simpleTag "Plugs-In-Ampersand-Script")     (map mkXmlTree (vplugs f))]
+--          ++ [ Elem (simpleTag "Plugs-also-derived-ones") (map mkXmlTree (plugs f))]
+          ++ [ Elem (simpleTag "Patterns")     (map mkXmlTree (patterns f))] 
+          ++ [ Elem (simpleTag "InterfaceS")   (map mkXmlTree (interfaceS f))] 
+          ++ [ Elem (simpleTag "InterfaceG")   (map mkXmlTree (interfaceG f))] 
+      --    ++ [ Elem (simpleTag "Activities")   (map mkXmlTree (interfaces f))] 
+          ++ [ Elem (simpleTag "Rules")        (map mkXmlTree (vrules f))] 
+          ++ [ Elem (simpleTag "GRules")       (map mkXmlTree (grules f))] 
+          ++ [ Elem (simpleTag "Declarations") (map mkXmlTree (vrels f))] 
+          ++ [ Elem (simpleTag "Violations")   (map violation2XmlTree (allViolations f))]
+          ++ [ still2bdone "Ontology" ] -- ++ [ Elem (simpleTag "Ontology") [mkXmlTree hhh] 
+          ++ [ Elem (simpleTag "Explanations") (map mkXmlTree (fSexpls f))]
+                 )
+             where violation2XmlTree :: (Rule,[Paire]) -> XTree
+                   violation2XmlTree (r,ps) = 
+                     Elem (Tag "Violation" [] )
+                      (
+                       Elem (simpleTag "ViolatedRule") [mkXmlTree r]
+                       :[Elem (simpleTag "Culprits")(map mkXmlTree ps)]
+                      )
+                 
+   instance XML Activity where
+     mkTag _ = Tag "Activity" [] 
+     mkXmlTree act
+        = Elem (mkTag act) (  
+             [ Elem (simpleTag "Rule")               [mkXmlTree (actRule act)]]
+          ++ [ Elem (simpleTag "Editable Relations") (map mkXmlTree (actTrig   act)) |not (null (actTrig   act))] 
+          ++ [ Elem (simpleTag "Affected Relations") (map mkXmlTree (actAffect act)) |not (null (actAffect act))] 
+          ++ [ Elem (simpleTag "Affected Quads")     []] -- TODO
+          ++ [ Elem (simpleTag "ECArules")           (map mkXmlTree (actEcas   act)) |not (null (actEcas   act))] 
+          ++ [ Elem (simpleTag "Explanations")       (map mkXmlTree (actPurp   act)) |not (null (actPurp   act))] 
+           )
+
+   instance XML FPA where
+     mkTag _ = Tag "FPA" [] 
+     mkXmlTree fpa'
+        = Elem (mkTag fpa') []  -- TODO make content for this XML field
+
+
+   instance XML Pattern where
+     mkTag pat = Tag "Pattern" [ nameToAttr pat]
+     mkXmlTree pat
+        = Elem (mkTag pat) (  
+             [ Elem (simpleTag "Rules")        (map mkXmlTree (ptrls pat)) |not (null (ptrls pat))] 
+          ++ [ Elem (simpleTag "Gens")         (map mkXmlTree (ptgns pat)) |not (null (ptgns pat))] 
+          ++ [ Elem (simpleTag "Declarations") (map mkXmlTree (ptdcs pat)) |not (null (ptdcs pat))] 
+          ++ [ Elem (simpleTag "Concepts")     (map mkXmlTree (conceptDefs pat)) |not (null (conceptDefs 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 (objatsLegacy 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])
+               (ECps (l,r)) -> Elem (simpleTag "RMUL") (map mkXmlTree [l,r])
+               (ERad (l,r)) -> Elem (simpleTag "RADD") (map mkXmlTree [l,r])
+               (EPrd (l,r)) -> Elem (simpleTag "RPRD") (map mkXmlTree [l,r])
+               EKl0 e       -> Elem (simpleTag "CLS0") [mkXmlTree e]
+               EKl1 e       -> Elem (simpleTag "CLS1") [mkXmlTree e]
+               EFlp e       -> Elem (simpleTag "CONV") [mkXmlTree e]
+               ECpl e       -> Elem (simpleTag "CMPL") [mkXmlTree e]
+               EBrk e       -> mkXmlTree e
+               EDcD dcl     -> Elem (simpleTag "EDcD") [mkXmlTree dcl]
+               EDcI c       -> Elem (simpleTag "EDcI") [mkXmlTree c]
+               EEps i sgn   -> Elem (simpleTag "EEps") [mkXmlTree i,mkXmlTree sgn]
+               EDcV sgn     -> Elem (simpleTag "EDcV") [mkXmlTree sgn]
+               EMp1 atm c   -> Elem (simpleTag ("ATOM="++atm)) [mkXmlTree c]
+
+   instance XML PPurpose where
+     mkTag expl =
+       Tag "PRef2" atts
+        
+--        = case expl of
+--                PRef2ConceptDef{}  -> Tag "ExplConceptDef"  atts
+--                PRef2Declaration{} -> Tag "ExplDeclaration" atts
+--                PRef2Rule{}        -> Tag "ExplRule"        atts
+--                PRef2IdentityDef{} -> Tag "ExplIdentityDef" atts
+--                PRef2Pattern{}     -> Tag "ExplPattern"     atts
+--                PRef2Process{}     -> Tag "ExplProcess"     atts
+--                PRef2Interface{}   -> Tag "ExplInterface"   atts
+--                PRef2Context{}     -> Tag "ExplContext"     atts
+--                PRef2Fspc{}        -> Tag "ExplContext"     atts
+           where
+            atts ::  [XAtt]
+            atts = [mkAttr "Explains" (name expl)
+                   ,mkAttr "Markup" (show(pexMarkup expl))
+                   ,mkAttr "Ref" (pexRefID 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" (explRefId expl)]
+
+--        = case expl of
+--                ExplConceptDef  cdef  lang ref _ -> Tag "ExplConceptDef"  (atts cdef lang ref)
+--                ExplDeclaration d     lang ref _ -> Tag "ExplDeclaration" (atts (name d++name(source d)++name(target d)) lang ref)
+--                ExplRule        rname lang ref _ -> Tag "ExplRule"        (atts rname lang ref)
+--                ExplIdentityDef kname lang ref _ -> Tag "ExplIdentityDef" (atts kname lang ref)
+--                ExplViewDef     kname lang ref _ -> Tag "ExplViewDef"     (atts kname lang ref)
+--                ExplPattern     pname lang ref _ -> Tag "ExplPattern"     (atts pname lang ref)
+--                ExplProcess     pname lang ref _ -> Tag "ExplProcess"     (atts pname lang ref)
+--                ExplInterface   cname lang ref _ -> Tag "ExplInterface"   (atts cname lang ref)
+--                ExplContext     cname lang ref _ -> Tag "ExplContext"     (atts cname lang ref)
+--           where
+--            atts :: String -> Lang -> String -> [XAtt]
+--            atts str lang ref = [mkAttr "Explains" str
+--                                ,mkAttr "Lang" (show lang)
+--                                ,mkAttr "Ref" ref]
+     mkXmlTree expl 
+         = Elem (mkTag expl) [PlainText ((validXML.show.explMarkup) expl)]
+
+
+   instance XML A_Gen where
+     mkTag g@Isa{} = Tag "Isa" (mkAttr "Specific" (show (genspc g))
+                                :[mkAttr "Generic" (show (gengen g))]
+                               )
+     mkTag g@IsE{} = Tag "IsE" (mkAttr "Specific" (show (genspc g))
+                                :[mkAttr "Generics" (show c) | c<-genrhs g]
+                               )
+     mkXmlTree g = Node (mkTag g) 
+
+   instance XML Sign where
+     mkTag sgn = Tag "Sign" (mkAttr "Source" (show (source sgn))
+                            :[mkAttr "Target" (show (target sgn))]
+                            )
+     mkXmlTree sgn = Node (mkTag sgn) 
+
+   instance XML Declaration where
+     mkTag d = Tag "Association" ([nameToAttr d]
+                                ++[ mkAttr "type" t]
+                                ++ extraAtts )
+            where t = case d of
+                        Sgn{} -> "Sgn"
+                        Isn{} -> "Isn"
+                        Vs{} -> "Vs"
+                  extraAtts = case d of
+                                Sgn{} -> [mkAttr "IsSignal" (show (decissX d))]
+                                _     -> []
+            
+     mkXmlTree d = Elem (mkTag d)
+        (case d of  
+          Sgn{} 
+                ->  [Node (Tag "Source" [mkAttr "concept" (name(source d))])]
+                  ++[Node (Tag "Target" [mkAttr "concept" (name(target d))])]
+                  ++[Elem (simpleTag "MultFrom") [PlainText (multiplicity (multiplicities d))]]
+                  ++[Elem (simpleTag "MultTo") [PlainText (multiplicity (map flp (multiplicities d)))]]
+                  ++[Elem (simpleTag "Pragma") 
+                             [PlainText (show (prL++"%f"++prM++"%t"++prR))] 
+                                | not (null (prL++prM++prR))]
+                  ++[Elem (simpleTag "Meaning") [PlainText "Still 2 be done"]
+                    --         [PlainText (explainContent2String LaTeX True (decMean d))]
+                    ]
+--                  ++[Elem (simpleTag "Population") 
+--                             (map mkXmlTree (decpopu d)) 
+--                                | not (null (decpopu d))]                 
+          Isn{}
+                ->  [Elem (simpleTag "Type") [mkXmlTree (source d)]]
+          Vs{}
+                ->  Elem (simpleTag "Generic") [mkXmlTree (source d)]
+                    :[Elem (simpleTag "Specific")[mkXmlTree (target d)]]
+           ) 
+       where
+         multiplicity ms | null ([Sur,Inj]>-ms) = "1"
+                         | null (    [Inj]>-ms) = "0..1"
+                         | null ([Sur]    >-ms) = "1..n"
+                         | otherwise            = "0..n"
+         prL = decprL d
+         prM = decprM d
+         prR = decprR d
+
+   instance XML Paire where
+     mkTag p = Tag "link" atts
+                where
+                   atts = mkAttr "from" (srcPaire p)
+                          :[mkAttr "to"   (trgPaire p)]
+     mkXmlTree p = Elem (mkTag p) []
+                        
+   instance XML ConceptDef where
+     mkTag f = Tag "ConceptDef" ( mkAttr "name" (cdcpt f)
+                                  : [mkAttr "Trace" (cdref f) |not (null (cdref f))])
+     mkXmlTree f = Elem (mkTag f) (explainTree (cddef f))
+   
+
+   instance XML A_Concept where
+     mkTag f = Tag "A_Concept" [nameToAttr f]
+     mkXmlTree f
+        = Node (mkTag f)  
+
+
+   instance XML (ECArule) where
+     mkTag _ = Tag "ECArule" []
+     mkXmlTree _ = still2bdone "ECArule"
+   
+   instance XML (Declaration->ECArule) where
+     mkTag _ = Tag "ECArule" []
+     mkXmlTree _ = still2bdone "Declaration->ECArule"
+   
+   instance XML PlugSQL where --TODO151210 -> tags for BinSQL and ScalarSQL
+     mkTag p = Tag "PlugSql" [ nameToAttr p]
+     mkXmlTree p 
+      = Elem (mkTag p) 
+             [ Elem (simpleTag "Fields") (map mkXmlTree (fields p))]
+   instance XML SqlField where
+      mkTag x = Tag "Field" (   [mkAttr "name" (fldname x)]
+                              ++[mkAttr "type" (showSQL (fldtype x))]
+                              ++[mkAttr "null" (show (fldnull x))]
+                              ++[mkAttr "uniq" (show (flduniq x))]
+                              ++[mkAttr "auto" (show (fldauto x))]
+                              )
+      mkXmlTree sf = Elem (mkTag sf)
+                        [Elem (simpleTag "Expression") [mkXmlTree (fldexpr sf)]]
+                        
+   attributesTree :: [ObjectDef] -> [XTree]
+   attributesTree atts = [Elem (simpleTag "Attributes") 
+                               (map mkXmlTree atts)    |not(null atts)]
+
+   descriptionTree :: Expression -> [XTree]
+   descriptionTree f = [Elem (simpleTag "Description")
+                           [mkXmlTree f] ]
+
+   explainTree :: String -> [XTree]
+   explainTree str = [Elem (simpleTag "Explanation")
+                           [PlainText (validXML str)] | not (null str)]
+                           
+                           
+   -- | XML has a special set of characters that cannot be used in normal XML strings. 
+   validXML :: String -> String
+   validXML []       = []
+   validXML ('&':s)  = "&amp;"++validXML s
+   validXML ('<':s)  = "&lt;"++validXML s
+   validXML ('>':s)  = "&gt;"++validXML s
+   validXML ('"':s)  = "&quot;"++validXML s
+   validXML ('\'':s) = "&#39;"++validXML s
+   validXML (c:s)    = c:validXML s
+ src/lib/DatabaseDesign/Ampersand/Fspec/Switchboard.hs view
@@ -0,0 +1,256 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Fspec.Switchboard
+    (SwitchBdDiagram(..),switchboardAct,sbDiagram,processModel) where
+-- Go to  http://hackage.haskell.org/package/graphviz  for Graphviz bindings for Haskell.
+ 
+   import Data.GraphViz
+   import Data.GraphViz.Attributes.Complete
+   import Data.List
+   import DatabaseDesign.Ampersand.Basics        (fatalMsg,Identified(..),flp)
+   import DatabaseDesign.Ampersand.ADL1
+   import DatabaseDesign.Ampersand.Classes
+   import DatabaseDesign.Ampersand.Fspec.Fspec
+   import DatabaseDesign.Ampersand.Fspec.ShowADL (ShowADL(..), LanguageDependent(..))
+   import Data.String
+   
+--   import DatabaseDesign.Ampersand.Fspec.ShowECA (showECA) -- for testing purposes
+   
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Fspec.Switchboard"
+
+   data SwitchBdDiagram
+    = SBdgrm { sbName :: String
+             , sbdotGraph :: DotGraph String
+             }
+   instance Identified SwitchBdDiagram where
+      name = sbName
+
+   processModel :: FProcess -> DotGraph String
+   processModel fp
+    = DotGraph { strictGraph = False
+               , directedGraph = True
+               , graphID = Just (Str (fromString "Process Model"))
+               , graphStatements 
+                  = DotStmts { attrStmts = [GraphAttrs [{-Splines SplineEdges,-} RankDir FromLeft]]
+                             , subGraphs = []
+                             , nodeStmts = activityNodes
+                             , edgeStmts = edges
+                             }
+               }
+      where
+         activityNodes = [ DotNode { nodeID         = "act_"++name a
+                                   , nodeAttributes = [Style [SItem Filled []], FillColor [WC(X11Color Orange) Nothing], Label (StrLabel (fromString (name a)))]
+                                   }
+                         | a<-fpActivities fp]
+         edges         = nub
+                         [ DotEdge { fromNode = "act_"++name from
+                                   , toNode   = "act_"++name to
+                                   , edgeAttributes = [Len 2, Label (StrLabel (fromString (show e++" "++name d))), Dir Forward]
+                                   }
+                         | (from,to,e,d) <- allEdges
+                         ]
+         allEdges  = nub[(from,to,e,d) | (e,d,from)<-eventsOut, (e',d',to)<-eventsIn, e==e', d==d']
+{-
+data Activity = Act { actRule ::   Rule
+                    , actTrig ::   [Relation]
+                    , actAffect :: [Relation]
+                    , actQuads ::  [Quad]
+                    , actEcas ::   [ECArule]
+                    , actPurp ::   [Purpose]
+                    }
+data ECArule= ECA { ecaTriggr :: Event     -- The event on which this rule is activated
+                  , ecaDelta :: Relation  -- The delta to be inserted or deleted from this rule. It actually serves very much like a formal parameter.
+                  , ecaAction :: PAclause  -- The action to be taken when triggered.
+                  , ecaNum :: Int       -- A unique number that identifies the ECArule within its scope.
+                  }
+data Event = On { eSrt :: InsDel
+                  , eRel :: Relation
+                  } deriving (Show,Eq)
+-}
+         eventsIn  = [(e,d,act) | act<-fpActivities fp, eca<-actEcas act, let On e d = ecaTriggr eca]
+         eventsOut = [(e,d,act) | act<-fpActivities fp, eca<-actEcas act, (e,d)<-events (ecaAction eca)]
+   colorRule :: Rule -> X11Color
+   colorRule r  | isSignal r = Orange
+                | otherwise  = Green
+
+   sbDiagram :: Fspc -> Fswitchboard -> SwitchBdDiagram
+   sbDiagram fSpec fsb
+    = SBdgrm
+        { sbName = name fSpec
+        , sbdotGraph
+           = DotGraph { strictGraph = False
+                      , directedGraph = True
+                      , graphID = Just (Str (fromString "Switchboard"))
+                      , graphStatements 
+                         = DotStmts { attrStmts = [GraphAttrs [Splines SplineEdges, RankDir FromLeft]]
+                                    , subGraphs = []
+                                    , nodeStmts = inEvNodes++conjNodes++ecaNodes++outEvNods
+                                    , edgeStmts = edgesEvCj++edgesCjEc++edgesEcEv
+                                    }
+                      }
+        }
+      where
+        --DESCR -> The relations from which changes can come
+        inEvNodes = [ DotNode { nodeID         = nameINode eventsIn ev
+                              , nodeAttributes = [Label (StrLabel (fromString (show (eSrt ev)++" "++showADL (eDcl ev))))]
+                              }
+                    | ev<-eventsIn
+                    ]
+        --DESCR -> All conjuncts
+        conjNodes = [ DotNode { nodeID         = nameCNode (fsbConjs fsb) (rul,c)
+                              , nodeAttributes = [Style [SItem Filled []], FillColor [WC(X11Color (colorRule rul)) Nothing], (Label . StrLabel . fromString . name) rul]
+                              }
+                    | (rul,c)<-fsbConjs fsb]
+
+        --DESCR -> All ECA rules
+        ecaNodes  = [ DotNode { nodeID         = nameENode (fsbECAs fsb) eca
+                              , nodeAttributes = if isBlk (ecaAction eca)
+                                                 then [Style [SItem Filled []], FillColor [WC(X11Color Red)Nothing], (Label . StrLabel . fromString) ("ERR #"++show (ecaNum eca))]
+                                                 else [(Label . StrLabel . fromString. showADL) eca]
+                              }
+                    | eca<-fsbECAs fsb, not (isBlk (ecaAction eca))]
+
+        --DESCR -> The relations to which changes are made
+        outEvNods = [ DotNode { nodeID         = nameONode eventsOut ev
+                              , nodeAttributes = [Label (StrLabel (fromString (show (eSrt ev)++" "++showADL (eDcl ev))))]
+                              }
+                    | ev<-eventsOut
+                    ]
+        --DESCR -> Each edge represents an insert between a relation on the left and a term on the right to which the relation contributes to an insert.
+        edgesEvCj = [ DotEdge { fromNode = nameINode eventsIn ev
+                              , toNode   = nameCNode (fsbConjs fsb) (rul,c)
+                              , edgeAttributes = [Dir Forward]
+                              }
+                    | (rul,c)<-fsbConjs fsb, ev<-eventsIn, eDcl ev `elem` declsUsedIn c]
+        edgesCjEc = [ DotEdge { fromNode = nameCNode (fsbConjs fsb) (rul,c)
+                              , toNode   = nameENode (fsbECAs fsb) eca
+                              , edgeAttributes = [Dir Forward]
+                              }
+                    | (rul,c)<-fsbConjs fsb, eca<-fsbECAs fsb, not (isBlk (ecaAction eca)), rul `elem` concat [r | (_,r)<-paMotiv (ecaAction eca)] ]
+        edgesEcEv = nub
+                    [ DotEdge { fromNode = nameENode (fsbECAs fsb) eca
+                              , toNode   = nameONode eventsOut (On tOp rel)
+                              , edgeAttributes = [Dir Forward]
+                              }
+                    | eca<-fsbECAs fsb, not (isBlk (ecaAction eca))
+                    , Do tOp rel _ _<-dos (ecaAction eca)
+{- for testing purposes:
+                    , doAct<-dos (ecaAction eca)
+                    , if not (isDo doAct) then fatal 136 ("not in \"Do\" shape: "++showECA fSpec "\n  " doAct) else True
+                    , let Do tOp expr _ _=doAct
+                          isTm ERel{} = True
+                          isTm _    = False
+                    , if not (isTm expr) then fatal 138 ("not in \"ERel\" shape: "++showECA fSpec "\n  " doAct) else True
+                    , let ERel rel _ = expr
+Note:
+The expression 'isDo doAct' will become False if a property is being maintained
+(a property is a relation that are both Sym and Asy).   
+This situation is implicitly avoided by 'Do tOp (ERel rel _) _ _<-dos (ecaAction eca)'.
+-}
+                    ]
+        nameINode = nmLkp fSpec "in_"
+        nameCNode = nmLkp fSpec "cj_"
+        nameENode = nmLkp fSpec "eca_"
+        nameONode = nmLkp fSpec "out_"
+        eventsIn  = nub [ecaTriggr eca | eca<-fsbECAs fsb, not (isBlk (ecaAction eca)) ]
+        eventsOut = nub [On tOp rel | eca<-fsbECAs fsb, let act=ecaAction eca, not (isBlk act), Do tOp rel _ _<-dos act]
+
+   switchboardAct :: Fspc -> Activity -> SwitchBdDiagram
+   switchboardAct fSpec act
+    = SBdgrm
+        { sbName = name act
+        , sbdotGraph
+           = DotGraph { strictGraph = False
+                      , directedGraph = True
+                      , graphID = Just (Str (fromString "Switchboard"))
+                      , graphStatements 
+                         = DotStmts { attrStmts = [GraphAttrs [Splines SplineEdges, RankDir FromLeft]]
+                                    , subGraphs = []
+                                    , nodeStmts = inMorNodes++conjunctNodes++outMorNodes
+                                    , edgeStmts = edgesIn++edgesOut
+                                    }
+                      }
+        }
+      where
+        fromRels     = nub (actTrig act)
+        toRels :: [Declaration]
+        toRels       = nub (actAffect act)
+        conjuncts    = nub [(cl_rule ccrs,c)
+                           | Quad _ ccrs<-actQuads act, c<- map rc_conjunct (cl_conjNF ccrs)]
+        --DESCR -> The relations from which changes can come
+        inMorNodes    = [ DotNode { nodeID         = nameINode fromRels r
+                                  , nodeAttributes = [Label (StrLabel (fromString (showADL r)))]
+                                  }
+                        | r<-fromRels
+                                                  --TODOHAN        , (not.null) [e |e<-edgesIn, (nodeID  (fromNode e))==nameINode fromRels r]
+                        ]
+
+        --DESCR -> The relations to which changes are made
+        outMorNodes   = [ DotNode { nodeID         = nameONode toRels r
+                                  , nodeAttributes = [Label (StrLabel (fromString (showADL r)))]
+                                  }
+                        | r<-toRels
+                  --TODOHAN     , (not.null) [e |e<-edgesOut, (nodeID . toNode) e==nameONode toRels r ]
+                        ]
+
+        --DESCR -> All conjuncts
+        conjunctNodes = [ DotNode { nodeID         = nameCNode conjuncts (rul,c)
+                                  , nodeAttributes = [Style [SItem Filled []], FillColor [WC(X11Color (colorRule rul))Nothing], Label (StrLabel (fromString (name rul)))]
+                                  }
+                        | (rul,c)<-conjuncts]
+
+        --DESCR -> Each edge represents an insert between a relation on the left and a term on the right to which the relation contributes to an insert.
+        edgesIn       = [ DotEdge { fromNode       = nameINode fromRels r
+                                  , toNode         = nameCNode conjuncts (rul,c)
+                                  , edgeAttributes = [Label (StrLabel (fromString 
+                                                                      (if or (positiveIn c r) then "-" else
+                                                                       if or [not b |b<-positiveIn c r] then "+" else
+                                                                       "+-")))
+                                                     ,Dir Forward]
+                                  }
+                        | (rul,c)<-conjuncts, r<-declsUsedIn c, r `elem` fromRels]
+        edgesOut      = [ DotEdge { fromNode       = nameCNode conjuncts (rul,c)
+                                  , toNode         = nameONode toRels r
+                                  , edgeAttributes = [Label (StrLabel (fromString
+                                                                      (if or (positiveIn c r) then "+" else
+                                                                       if or [not b |b<-positiveIn c r] then "-" else
+                                                                       "+-")))
+                                                     ,Dir Forward]
+                                  }
+                        | (rul,c)<-conjuncts, r<-declsUsedIn c]
+        nameINode :: [Declaration] -> Declaration -> String
+        nameINode = nmLkp fSpec "in_"
+        nameCNode = nmLkp fSpec "cj_"
+        nameONode :: [Declaration] -> Declaration -> String
+        nameONode = nmLkp fSpec "out_"
+
+
+   nmLkp :: (LanguageDependent a, Eq a, ShowADL a) => Fspc -> String -> [a] -> a -> String
+   nmLkp _ prefix xs x
+    = head ([prefix++show (i::Int) | (i,e)<-zip [1..] xs, e==x]++
+            fatal 216 ("illegal lookup in nmLkp "++show prefix++": " ++showADL x++
+                       "\nin: ["++intercalate "\n    , " (map showADL xs)++"\n    ]")
+           )
+   positiveIn :: Expression -> Declaration -> [Bool]
+   positiveIn expr decl = f expr   -- all are True, so an insert in rel means an insert in expr
+    where
+     f (EEqu _)     = fatal 245 "Illegal call of positiveIn."
+     f (EImp (l,r)) = f (notCpl l .\/. r)
+     f (EIsc (l,r)) = f l ++ f r
+     f (EUni (l,r)) = f l ++ f r
+     f (EDif (l,r)) = f (l ./\. notCpl r)
+     f (ELrs (l,r)) = f (l .!. notCpl (flp r))
+     f (ERrs (l,r)) = f (notCpl (flp l) .!. r)
+     f (ECps (l,r)) = f l ++ f r
+     f (ERad (l,r)) = f l ++ f r
+     f (EPrd (l,r)) = f l ++ f r
+     f (EKl0 e)     = f e
+     f (EKl1 e)     = f e
+     f (EFlp e)     = f e
+     f (ECpl e)     = [ not b | b<- f e]
+     f (EBrk e)     = f e
+     f (EDcD d)     = [ True | d==decl ]
+     f (EDcI c)     = [ True | detyp decl==c ]
+     f EEps{}       = []
+     f EDcV{}       = []
+     f EMp1{}       = []
+ src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/ADL2Fspec.hs view
@@ -0,0 +1,996 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Fspec 
+    (makeFspec,actSem, delta, allClauses, quads, assembleECAs, preEmpt, genPAclause, editable, conjuncts)
+  where
+   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+   import DatabaseDesign.Ampersand.Core.Poset
+   import Prelude hiding (Ord(..),head)
+   import DatabaseDesign.Ampersand.ADL1.Rule
+   import DatabaseDesign.Ampersand.Basics
+   import DatabaseDesign.Ampersand.Classes
+   import DatabaseDesign.Ampersand.ADL1
+   import DatabaseDesign.Ampersand.Fspec.Fspec
+   import DatabaseDesign.Ampersand.Misc
+   import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms  --  (conjNF,disjNF,normPA, exprUni2list, exprIsc2list, exprCps2list)
+   import DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Plug
+--   import DatabaseDesign.Ampersand.Fspec.ShowHS -- only for diagnostic purposes during debugging
+   import DatabaseDesign.Ampersand.Fspec.ShowADL
+   import Text.Pandoc
+   import Data.List (nub,nubBy,intercalate,intersect,partition,group,delete)
+   import DatabaseDesign.Ampersand.ADL1.Expression
+   import Data.Char        (toLower)
+   head :: [a] -> a
+   head [] = fatal 30 "head must not be used on an empty list!"
+   head (a:_) = a
+
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Fspec.ToFspec.ADL2Fspec"
+
+   makeFspec :: Options -> A_Context -> Fspc
+   makeFspec flags context = fSpec
+    where
+        fSpec =
+            Fspc { fsName       = name context
+                 , fspos        = ctxpos context
+                   -- interfaceS contains the interfaces defined in the Ampersand script.
+                   -- interfaces are meant to create user interfaces, programming interfaces and messaging interfaces.
+                   -- A generic user interface (the Lonneker interface) is already available.
+                 , themes       = ctxthms context      -- The names of patterns/processes to be printed in the functional specification. (for making partial documentation)
+                 , fsLang       = ctxlang context      -- The default language for this specification, if specified at all.
+                 , vprocesses   = allProcs
+                 , vplugInfos   = definedplugs
+                 , plugInfos    = allplugs
+                 , interfaceS   = ctxifcs context -- interfaces specified in the Ampersand script
+                 , interfaceG   = [ifc | ifc<-interfaceGen, let ctxrel = objctx (ifcObj ifc)
+                                       , isIdent ctxrel && source ctxrel==ONE
+                                         || ctxrel `notElem` map (objctx.ifcObj) (interfaceS fSpec)
+                                       , allInterfaces flags]  -- generated interfaces
+                 , fSwitchboard = switchboard flags fSpec
+                 , fActivities  = [ makeActivity fSpec rul | rul <-processRules context]
+                 , fRoleRels    = mayEdit   context  -- fRoleRels says which roles may change the population of which relation.
+                 , fRoleRuls    = maintains context  -- fRoleRuls says which roles maintain which rules.
+                 , vrules       = vRules
+                 , grules       = gRules
+                 , invars       = invariants context
+                 , allRules     = allrules
+                 , vconjs       = let equalOnConjunct a b = rc_conjunct a == rc_conjunct b
+                                  in nubBy equalOnConjunct (concatMap (cl_conjNF.qClauses)allQuads)
+                 , vquads       = allQuads
+                 , vEcas        = {-preEmpt-} assembleECAs [q | q<-vquads fSpec, isInvariantQuad q] -- TODO: preEmpt gives problems. Readdress the preEmption problem and redo, but properly.
+                 , vrels        = calculatedDecls
+                 , allUsedDecls = declsUsedIn context
+                 , allDecls     = alldecls
+                 , allConcepts  = concs context
+                 , kernels      = constructKernels
+                 , fsisa        = []
+                 , vpatterns    = patterns context
+                 , vgens        = gens context
+                 , vIndices     = identities context
+                 , vviews       = viewDefs context
+                 , vConceptDefs = conceptDefs context
+                 , fSexpls      = ctxps context
+                 , metas        = ctxmetas context
+                 , initialPops  = initialpops
+                 , allViolations = [(r,vs) |r<- allrules, not (isSignal r), let vs = ruleviolations (gens context) initialpops r,  not (null vs)]
+                 }
+        alldecls = declarations context
+        allQuads = quads flags (\_->True) allrules
+        initialpops = userDefPops++singletonpops
+        userDefPops = ctxpopus context
+        singletonpops = [ PCptPopu{ popcpt = head [c | EMp1 _ c<-cl ]
+                                  , popas  =      [a | EMp1 a _<-cl ] 
+                                  } 
+                        | cl<-eqCl (\(EMp1 _ c)->c) (mp1Exprs context)]
+        isInvariantQuad q = null [r | (r,rul)<-maintains context, rul==cl_rule (qClauses q)]
+        allrules = vRules ++ gRules
+        vRules = udefrules context   -- all user defined rules
+        gRules = multrules context++identityRules context
+        allProcs = [ FProc {fpProc = p
+                           ,fpActivities =selectActs p
+                           } | p<-ctxprocs context ]
+                   where selectActs p   = [act | act<-fActivities fSpec
+                                               , (not.null) (selRoles p act)]
+                         selRoles p act = [r | (r,rul)<-maintains context, rul==actRule act, r `elem` roles p]
+        -- | allDecs contains all user defined plus all generated relations plus all defined and computed totals.
+        calcProps :: Declaration -> Declaration
+        calcProps d = d{decprps_calc = Just calculated}
+            where calculated = decprps d `uni` [Tot | d `elem` totals]
+                                         `uni` [Sur | d `elem` surjectives]
+        calculatedDecls = map calcProps alldecls
+        constructKernels = foldl f (group (delete ONE (concs context))) (gens context)
+            where f disjuncLists g = concat haves : nohaves
+                    where
+                      (haves,nohaves) = partition (not.null.intersect (concs g)) disjuncLists
+     -- determine relations that are total (as many as possible, but not necessarily all)
+        totals      = [ d |       EDcD d  <- totsurs ]
+        surjectives = [ d | EFlp (EDcD d) <- totsurs ]
+        totsurs :: [Expression]
+        totsurs
+         = nub [rel | q<-quads flags visible (invariants context), isIdent (qDcl q)
+                    , x<-cl_conjNF (qClauses q), Dnf antcs conss<-rc_dnfClauses x
+                    , let antc = conjNF (foldr (./\.) (EDcV (sign (head (antcs++conss)))) antcs)
+                    , isRfx antc -- We now know that I is a subset of the antecedent of this dnf clause.
+                    , cons<-map exprCps2list conss
+               -- let I |- r;s;t be an invariant rule, then r and s and t~ and s~ are all total.
+                    , rel<-init cons++[flp r | r<-tail cons]
+                    ]
+          where
+            visible _ = True -- for computing totality, we take all quads into account.
+
+        --------------
+        --making plugs
+        --------------
+        vsqlplugs = [ (makeUserDefinedSqlPlug context p) | p<-ctxsql context] --REMARK -> no optimization like try2specific, because these plugs are user defined
+        definedplugs = map InternalPlug vsqlplugs
+                    ++ map ExternalPlug (ctxphp context)
+        allplugs = definedplugs ++      -- all plugs defined by the user
+                   genPlugs             -- all generated plugs
+        genPlugs = [InternalPlug (rename p (qlfname (name p)))
+                   | p <- uniqueNames (map name definedplugs) -- the names of definedplugs will not be changed, assuming they are all unique
+                                      (makeGeneratedSqlPlugs flags context totsurs entityRels)
+                   ]
+        -- declarations to be saved in generated plugs: if decplug=True, the declaration has the BYPLUG and therefore may not be saved in a database
+        -- WHAT -> is a BYPLUG?
+        entityRels = [ d | d<-calculatedDecls, not (decplug d)] -- The persistent relations.
+
+        qlfname x = if null (namespace flags) then x else "ns"++namespace flags++x
+
+        --TODO151210 -> Plug A is overbodig, want A zit al in plug r
+--CONTEXT Temp
+--PATTERN Temp
+--r::A*B[TOT].
+--t::E*ECps[UNI].
+--ENDPATTERN
+--ENDCONTEXT
+{-
+    **************************************
+    * Plug E                               *
+    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
+    * t  [UNI]                             *
+    **************************************
+    * Plug ECps                            *
+    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
+    **************************************
+    * Plug B                               *
+    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
+    **************************************
+    * Plug A                               *
+    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
+    **************************************
+    * Plug r                               *
+    * I  [INJ,SUR,UNI,TOT,SYM,ASY,TRN,RFX] *
+    * r  [TOT]                             *
+    **************************************
+-}
+        -------------------
+        --END: making plugs
+        -------------------
+        -------------------
+        --making interfaces
+        -------------------
+        -- interfaces (type ObjectDef) can be generated from a basic ontology. That is: they can be derived from a set
+        -- of relations together with multiplicity constraints. That is what interfaceG does.
+        -- This is meant to help a developer to build his own list of interfaces, by providing a set of interfaces that works.
+        -- The developer may relabel attributes by names of his own choice.
+        -- This is easier than to invent a set of interfaces from scratch.
+
+        -- Rule: a interface must be large enough to allow the required transactions to take place within that interface.
+        -- Attributes of an ObjectDef have unique names within that ObjectDef.
+
+--- generation of interfaces:
+--  Ampersand generates interfaces for the purpose of quick prototyping.
+--  A script without any mention of interfaces is supplemented
+--  by a number of interface definitions that gives a user full access to all data.
+--  Step 1: select and arrange all declarations to obtain a set cRels of total relations
+--          to ensure insertability of entities (signal declarations are excluded)
+        cRels = [     EDcD d  | d@Sgn{}<-declarations context, not(deciss d), isTot d, not$decplug d]++
+                [flp (EDcD d) | d@Sgn{}<-declarations context, not(deciss d), not (isTot d) && isSur d, not$decplug d]
+--  Step 2: select and arrange all declarations to obtain a set dRels of injective relations
+--          to ensure deletability of entities (signal declarations are excluded)
+        dRels = [     EDcD d  | d@Sgn{}<-declarations context, not(deciss d), isInj d, not$decplug d]++
+                [flp (EDcD d) | d@Sgn{}<-declarations context, not(deciss d), not (isInj d) && isUni d, not$decplug d]
+--  Step 3: compute longest sequences of total expressions and longest sequences of injective expressions.
+        maxTotPaths = clos cRels   -- maxTotPaths = cRels+, i.e. the transitive closure of cRels
+        maxInjPaths = clos dRels   -- maxInjPaths = dRels+, i.e. the transitive closure of dRels
+        --    Warshall's transitive closure algorithm, adapted for this purpose:
+        clos :: [Expression] -> [[Expression]]
+        clos xs
+         = foldl f [ [ x ] | x<-xs] (nub (map source xs) `isc` nub (map target xs))
+           where
+             f :: [[Expression]] -> A_Concept -> [[Expression]]
+             f q x = q ++ [l ++ r | l <- q, x == target (last l),
+                                    r <- q, x == source (head r), null (l `isc` r)]
+
+--  Step 4: i) generate interfaces starting with INTERFACE concept: I[Concept]
+--          ii) generate interfaces starting with INTERFACE concepts: V[ONE*Concept] 
+--          note: based on a theme one can pick a certain set of generated interfaces (there is not one correct set)
+--                default theme => generate interfaces from the clos total expressions and clos injective expressions (see step1-3).
+--                student theme => generate interface for each concept with declarations where concept is source or target (note: step1-3 are skipped)
+        interfaceGen = step4a ++ step4b
+        step4a
+         | theme flags == StudentTheme 
+         = [Ifc { ifcParams = directdeclsExprs
+                , ifcArgs   = []
+                , ifcObj    = Obj { objnm   = name c ++ " (instantie)"
+                                  , objpos  = Origin "generated object for interface for each concept in TblSQL or ScalarSQL"
+                                  , objctx  = EDcI c
+                                  , objmsub = Just . Box c $
+                                              Obj { objnm   = "I["++name c++"]"
+                                                   , objpos  = Origin "generated object: step 4a - default theme"
+                                                   , objctx  = EDcI c
+                                                   , objmsub = Nothing
+                                                   , objstrs = [] }
+                                              :[Obj { objnm   = case dcl of
+                                                                  EDcD d -> name d ++ "::"++name (source d)++"*"++name (target d)
+                                                                  _      -> fatal 246 "Invalid expression for a parameter."
+                                                    , objpos  = Origin "generated object: step 4a - default theme"
+                                                    , objctx  = if source dcl==c then dcl else flp dcl
+                                                    , objmsub = Nothing
+                                                    , objstrs = [] }
+                                               | dcl <- directdeclsExprs]
+                                  , objstrs = [] }
+                , ifcPos    = Origin "generated interface for each concept in TblSQL or ScalarSQL"
+                , ifcPrp    = "Interface " ++name c++" has been generated by Ampersand."
+                , ifcRoles = []
+                }
+           | c<-concs fSpec, let directdeclsExprs = [EDcD d | d<-declarations fSpec, c `elem` concs d]]
+         --end student theme
+         --otherwise: default theme
+         | otherwise --note: the uni of maxInj and maxTot may take significant time (e.g. -p while generating index.htm)
+                     --note: associations without any multiplicity are not in any Interface
+                     --note: scalars with only associations without any multiplicity are not in any Interface
+         = let recur es
+                = [ Obj { objnm   = showADL t
+                        , objpos  = Origin "generated recur object: step 4a - default theme"
+                        , objctx  = t
+                        , objmsub = Just . Box (target t) $ recur [ pth | (_:pth)<-cl, not (null pth) ]
+                        , objstrs = [] }
+                  | cl<-eqCl head es, (t:_)<-take 1 cl] -- 
+               -- es is a list of expression lists, each with at least one expression in it. They all have the same source concept (i.e. source.head)
+               -- Each expression list represents a path from the origin of a box to the attribute.
+               -- 16 Aug 2011: (recur trace es) is applied once where es originates from (maxTotPaths `uni` maxInjPaths) both based on clos
+               -- Interfaces for I[Concept] are generated only for concepts that have been analysed to be an entity.
+               -- These concepts are collected in gPlugConcepts
+               gPlugConcepts = [ c | InternalPlug plug@TblSQL{}<-genPlugs , (c,_)<-take 1 (cLkpTbl plug) ]
+               -- Each interface gets all attributes that are required to create and delete the object.
+               -- All total attributes must be included, because the interface must allow an object to be deleted.
+           in
+           [Ifc { ifcParams = [ p | p <- concatMap primitives (expressionsIn objattributes), not (isIdent p)]
+                , ifcArgs   = []
+                , ifcObj    = Obj { objnm   = name c
+                                  , objpos  = Origin "generated object: step 4a - default theme"
+                                  , objctx  = EDcI c
+                                  , objmsub = Just . Box c $ objattributes
+                                  , objstrs = [] }
+                , ifcPos    = Origin "generated interface: step 4a - default theme"
+                , ifcPrp    = "Interface " ++name c++" has been generated by Ampersand."
+                , ifcRoles  = []
+                }
+           | cl <- eqCl (source.head) [ pth | pth<-maxTotPaths `uni` maxInjPaths, (source.head) pth `elem` gPlugConcepts ]
+           , let objattributes = recur cl
+           , not (null objattributes) --de meeste plugs hebben in ieder geval I als attribuut
+           , --exclude concept A without cRels or dRels (i.e. A in Scalar without total associations to other plugs) 
+             not (length objattributes==1 && isIdent(objctx(head objattributes)))  
+           , let e0=head cl, if null e0 then fatal 284 "null e0" else True
+           , let c=source (head e0)
+           ]
+        --end otherwise: default theme
+        --end stap4a
+        step4b --generate lists of concept instances for those concepts that have a generated INTERFACE in step4a 
+         = [Ifc { ifcParams = ifcParams ifcc
+                , ifcArgs   = ifcArgs   ifcc
+                , ifcObj    = Obj { objnm   = nm
+                                  , objpos  = Origin "generated object: step 4b"
+                                  , objctx  = EDcI ONE
+                                  , objmsub = Just . Box ONE $ [att]
+                                  , objstrs = [] }
+                , ifcPos    = ifcPos  ifcc
+                , ifcPrp    = ifcPrp  ifcc
+                , ifcRoles  = []
+                }
+           | ifcc<-step4a
+           , let c   = source(objctx (ifcObj ifcc))
+                 nm'::Int->String
+                 nm' 0  = plural (language flags)(name c)
+                 nm' i  = plural (language flags)(name c) ++ show i
+                 nms = [nm' i |i<-[0..], nm' i `notElem` map name (ctxifcs context)]
+                 nm
+                   | theme flags == StudentTheme = name c
+                   | null nms = fatal 355 "impossible"
+                   | otherwise = head nms
+                 att = Obj (name c) (Origin "generated attribute object: step 4b") (EDcV (Sign ONE c)) Nothing []
+           ]
+        ----------------------
+        --END: making interfaces
+        ----------------------
+
+
+   editable :: Expression -> Bool   --TODO deze functie staat ook in Calc.hs...
+   editable (EDcD Sgn{}) = True
+   editable _            = False
+
+{- makeActivity turns a process rule into an activity definition.
+Each activity can be mapped to a single interface.
+A call to such an interface takes the population of the current context to another population,
+while maintaining all invariants.
+-}
+   makeActivity :: Fspc -> Rule -> Activity
+   makeActivity fSpec rul
+    = let s = Act{ actRule   = rul
+                 , actTrig   = decls
+                 , actAffect = nub [ d' | (d,_,d')<-clos affectPairs, d `elem` decls]
+                 , actQuads  = invQs
+                 , actEcas   = [eca | eca<-vEcas fSpec, eDcl (ecaTriggr eca) `elem` decls]
+                 , actPurp   = [Expl { explPos = OriginUnknown
+                                     , explObj = ExplRule (name rul)
+                                     , explMarkup = A_Markup { amLang   = Dutch
+                                                             , amFormat = ReST
+                                                             , amPandoc = [Plain [Str "Waartoe activiteit ", Quoted SingleQuote [Str (name rul)], Str" bestaat is niet gedocumenteerd." ]]
+                                                             }
+                                     , explUserdefd = False
+                                     , explRefId = "Regel "++name rul
+                                     }
+                               ,Expl { explPos = OriginUnknown
+                                     , explObj = ExplRule (name rul)
+                                     , explMarkup = A_Markup { amLang   = English
+                                                             , amFormat = ReST
+                                                             , amPandoc = [Plain [Str "For what purpose activity ", Quoted SingleQuote [Str (name rul)], Str" exists remains undocumented." ]]
+                                                             }
+                                     , explUserdefd = False
+                                     , explRefId = "Regel "++name rul
+                                     }
+                               ]
+                 } in s
+    where
+-- declarations that may be affected by an edit action within the transaction
+        decls        = relsUsedIn rul
+-- the quads that induce automated action on an editable relation.
+-- (A quad contains the conjunct(s) to be maintained.)
+-- Those are the quads that originate from invariants.
+        invQs       = [q | q@(Quad _ ccrs)<-vquads fSpec, (not.isSignal.cl_rule.qClauses) q
+                         , (not.null) ((relsUsedIn.cl_rule) ccrs `isc` decls)] -- SJ 20111201 TODO: make this selection more precise (by adding inputs and outputs to a quad).
+-- a relation affects another if there is a quad (i.e. an automated action) that links them
+        affectPairs = [(qDcl q,[q], d) | q<-invQs, d<-(relsUsedIn.cl_rule.qClauses) q]
+-- the relations affected by automated action
+--      triples     = [ (r,qs,r') | (r,qs,r')<-clos affectPairs, r `elem` rels]
+----------------------------------------------------
+--  Warshall's transitive closure algorithm in Haskell, adapted to carry along the intermediate steps:
+----------------------------------------------------
+        clos :: (Eq a,Eq b) => [(a,[b],a)] -> [(a,[b],a)]     -- e.g. a list of pairs, with intermediates in between
+        clos xs
+          = foldl f xs (nub (map fst3 xs) `isc` nub (map thd3 xs))
+            where
+             f q x = q `un`
+                        [(a, qs `uni` qs', b') | (a, qs, b) <- q, b == x,
+                         (a', qs', b') <- q, a' == x]
+             fst3 (a,_,_) = a
+             thd3 (_,_,c) = c
+             ts `un` [] = ts
+             ts `un` ((a',qs',b'):ts')
+              = ([(a,qs `uni` qs',b) | (a,qs,b)<-ts, a==a' && b==b']++
+                 [(a,qs,b)           | (a,qs,b)<-ts, a/=a' || b/=b']++
+                 [(a',qs',b')        | (a',b') `notElem` [(a,b) |(a,_,b)<-ts]]) `un` ts'
+        
+
+   -- Quads embody the "switchboard" of rules. A quad represents a "proto-rule" with the following meaning:
+   -- whenever relation r is affected (i.e. tuples in r are inserted or deleted),
+   -- the rule may have to be restored using functionality from one of the clauses.
+   -- The rule is carried along for traceability.
+   quads :: Options -> (Declaration->Bool) -> [Rule] -> [Quad]
+   quads flags visible rs
+--    = [ LoopSearchQuad 
+--            { qDcl  = d
+--            , qRule = rule
+--            , debugStr = (show.conjNF .rrexp) rule -- "LOOP detected in:  ((show.conjuncts) rule) => (show.conjNF.rrexp) rule => show.cfProof (\_->"") .rrexp) rule"
+--            }
+    = [ Quad d (allClauses flags rule)
+      | rule<-rs, d<-relsUsedIn rule, visible d
+      ]
+
+-- The function allClauses yields an expression which has constructor EUni in every case.
+   allClauses :: Options -> Rule -> Clauses
+   allClauses flags rule = Clauses [RC { rc_int = i
+                                       , rc_rulename = name rule
+                                       , rc_conjunct = dnf2expr dnfClause
+                                       , rc_dnfClauses = allShifts flags dnfClause
+                                       } | (dnfClause,i)<-zip (conjuncts rule) [0..] ] rule
+
+   allShifts :: Options -> DnfClause -> [DnfClause]
+   allShifts _ conjunct = nub [ e'| e'<-shiftL conjunct++shiftR conjunct]
+-- allShifts conjunct = error $ show conjunct++concat [ "\n"++show e'| e'<-shiftL conjunct++shiftR conjunct] -- for debugging
+    where
+    {-
+     diagnostic
+      = intercalate "\n  "
+          [ "shiftL: [ "++intercalate "\n          , " [showHS flags "\n            " e | e<-shiftL conjunct    ]++"\n          ]"
+          , "shiftR: [ "++intercalate "\n          , " [showHS flags "\n            " e | e<-shiftR conjunct    ]++"\n          ]"
+          ] -}
+     shiftL :: DnfClause -> [DnfClause]
+     shiftL dc@(Dnf antcs conss)
+      | null antcs || null conss = [dc] --  shiftL doesn't work here. This is just to make sure that both antss and conss are really not empty
+      | otherwise                = [ Dnf ass (case css of
+                                               [] -> let antcExpr = foldr1 (./\.) ass in
+                                                     if source antcExpr==target antcExpr then [EDcI (source antcExpr)] else fatal 425 "antcExpr should be endorelation"
+                                               _  -> css
+                                             )
+                                   | (ass,css)<-nub (move antcs conss)
+                                   ]
+      where
+      -- example:  r;s /\ p;r |- x;y   and suppose x and y are both univalent.
+      --  antcs =  [ r;s, p;r ]
+      --  conss =  [ x;y ]
+       move :: [Expression] -> [Expression] -> [([Expression],[Expression])]
+       move ass [] = [(ass,[])]
+       move ass css
+        = (ass,css):
+          if and [ (not.isEDcI) cs | cs<-css]     -- all cs are nonempty because: (not.and.map isEDcI) cs ==> not (null cs)
+          then [ts | let headEs = map headECps css
+                   , length (eqClass (==) headEs) == 1                    -- example: True, because map head css == [ "x" ]
+                   , let h=head headEs                                    -- example: h= "x"
+                   , isUni h                                              -- example: assume True
+                   , ts<-move [flp h.:.as |as<-ass] (map tailECps css)]++ -- example: ts<-move [ [flp "x","r","s"], [flp "x","p","r"] ]  [ ["y","z"] ]
+               [ts | let lastEs = map lastECps css
+                   , length (eqClass (==) lastEs) == 1
+                   , let l=head lastEs
+                   , isInj l
+                   , ts<-move [as.:.flp l |as<-ass] (map initECps css)]   -- example: ts<-move [ ["r","s",flp "z"], ["p","r",flp "z"] ]  [ ["x","y"] ]
+          else []
+      -- Here is (informally) what the example does:
+      -- move [ r;s , p;r ] [ x;y ]
+      -- ( [ r;s , p;r ] , [ x;y ] ): [ ts | ts<-move [flp x.:.as | as<-[ r;s , p;r ] [ y ] ] ]
+      -- ( [ r;s , p;r ] , [ x;y ] ): ( [ x~;r;s , x~;p;r ] , [ y ] ): [ ts | ts<-move [flp y.:.as | as<-[ y~;x~;r;s , y~;x~;p;r ] [] ] ]
+      -- ( [ r;s , p;r ] , [ x;y ] ): ( [ x~;r;s , x~;p;r ] , [ y ] ): [ [ y~;x~;r;s , y~;x~;p;r ] , [] ] ]
+      -- [ ( [ r;s , p;r ] , [ x;y ] ), ( [ x~;r;s , x~;p;r ] , [ y ] ), ( [ y~;x~;r;s , y~;x~;p;r ] , [] ) ]
+
+     shiftR :: DnfClause -> [DnfClause]
+     shiftR dc@(Dnf antcs conss)
+      | null antcs || null conss = [dc] --  shiftR doesn't work here. This is just to make sure that both antss and conss are really not empty
+      | otherwise                = [ Dnf (case ass of
+                                           [] -> let consExpr = foldr1 (.\/.) css in
+                                                 if source consExpr==target consExpr then [EDcI (source consExpr)] else fatal 463 "consExpr should be endorelation"
+                                           _  -> ass
+                                         ) css
+                                   | (ass,css)<-nub (move antcs conss)
+                                   ]
+      where
+      -- example  "r;s /\ r;r |- x;y"   and suppose r is both surjective.
+      --  ass =  [ r;s , r;r ]
+      --  css =  [ x;y ]
+       move :: [Expression] -> [Expression] -> [([Expression],[Expression])]
+       move ass css = 
+        case ass of
+         [] -> [] -- was [([EDcI (target (last css))],css)]
+         _  -> 
+          (ass,css):
+          if and [ (not.isEDcI) as | as<-ass]
+          then [ts | let headEs = map headECps ass
+                   , length (eqClass (==) headEs) == 1                      -- example: True, because map headECps ass == [ "r", "r" ]
+                   , let h=head headEs                                      -- example: h= "r"
+                   , isSur h                                                -- example: assume True
+                   , ts<-move (map tailECps ass) [flp h.:.cs |cs<-css]]++   -- example: ts<-move  [["s"], ["r"]] [ [flp "r","x","y","z"] ]
+               [ts | let lastEs = map lastECps ass
+                   , length (eqClass (==) lastEs) == 1                      -- example: False, because map lastECps ass == [ ["s"], ["r"] ]
+                   , let l=head lastEs
+                   , isTot l
+                   , ts<-move (map initECps ass) [cs.:.flp l |cs<-css]]     -- is dit goed? cs.:.flp l wordt links zwaar, terwijl de normalisator rechts zwaar maakt.
+          else []
+      -- Here is (informally) what the example does:
+      -- move [ r;s , r;r ] [ x;y ]
+      -- ( [ r;s , r;r ] , [ x;y ] ): move [ s , r ] [ r~;x;y ]
+      -- ( [ r;s , r;r ] , [ x;y ] ): ( [ s , r ]  , [ r~;x;y ] ) : []
+      -- [ [ r;s , r;r ] , [ x;y ] ), ( [ s , r ]  , [ r~;x;y ] ) ]
+       diagnostic
+         = "\n  antcs: [ "++intercalate "\n         , " [showADL a | a<-antcs ]++"\n       ]"++
+           "\n  conss: [ "++intercalate "\n         , " [showADL c | c<-conss ]++"\n       ]"++
+           "\n  move:  [ "++intercalate "\n         , " ["("++sh " /\\ " as++"\n           ,"++sh " \\/ " cs++")" | (as,cs)<-move antcs conss ]++"\n       ]"
+       sh :: String -> [Expression] -> String
+       sh str es = intercalate str [ showADL e | e<-es] 
+
+     headECps :: Expression -> Expression
+     headECps expr = f expr
+      where f (ECps (l@ECps{},_)) = f l
+            f (ECps (l,_)) = l
+            f _ = expr
+
+     tailECps :: Expression -> Expression
+     tailECps expr = f expr
+      where f (ECps (ECps (l,r),q)) = f (ECps (l, ECps (r,q)))
+            f (ECps (_,r)) = r
+            f _ = EDcI (target expr)
+            
+     initECps :: Expression -> Expression
+     initECps expr = f expr
+      where f (ECps (l, ECps (r,q))) = initECps (ECps (ECps (l,r),q))
+            f (ECps (l,_)) = l
+            f _ = EDcI (source expr)
+
+     lastECps :: Expression -> Expression
+     lastECps expr = f expr
+      where f (ECps (_,r@ECps{})) = f r
+            f (ECps (_,r)) = r
+            f _ = expr
+
+     isEDcI :: Expression -> Bool
+     isEDcI EDcI{} = True
+     isEDcI _ = False
+
+
+-- Deze functie neemt verschillende clauses samen met het oog op het genereren van code.
+-- Hierdoor kunnen grotere brokken procesalgebra worden gegenereerd.
+   assembleECAs :: [Quad] -> [ECArule]
+   assembleECAs qs
+    = [] -- [er{ecaAction=normPA (ecaAction er)} | (ecarule,i) <- zip ecas [(1::Int)..], let er=ecarule i]
+      where
+       -- the quads that are derived for this fSpec contain dnf clauses.
+       -- A dnf clause dc that is generated from rule r contains the information how to restore the truth of r.
+       -- Suppose an insert or delete event on a relation rel has occurred and rel is used in rule r.
+       -- A restore action from dnf clause dc will then restore the truth of r.
+       
+       -- First, we harvest the quads from fSpec in quadruples.
+       -- rel    is a relation that may be affected by an (insert- or delete-) event.
+       -- dnfClauses is a set of dnf clauses that can restore the truth of conj after rel has been affected.
+       -- conj   is an expression that must remain true at all times.
+       -- rul    is the rule from which the above have been derived (for traceability)
+       -- these quadruples are organized per relation.
+       -- This puts together all dnf clauses we need for each relation.
+       relEqCls = eqCl fst4 [(dcl,rc_dnfClauses x,rc_conjunct x,cl_rule ccrs) | Quad dcl ccrs<-qs, x <-cl_conjNF ccrs]
+       -- The eca rules can now be assembled from the available material
+       ecas
+        = [ ECA (On ev dcl) delt act
+          | relEq <- relEqCls                   -- The material required for one relation
+          , let (dcl,_,_,_) = head relEq        -- This is the relation
+          , let EDcD delt   = delta (sign dcl)  -- delt is a placeholder for the pairs that have been inserted or deleted in rel.
+          , ev<-[Ins,Del]                       -- This determines the event: On ev rel
+          , let act = ALL [ CHC [ (if isTrue  clause' || isTrue step then Nop else
+                                   if isFalse clause'                then Blk else
+--                                 if not (visible rel) then Blk else
+                                   let visible _ = True in genPAclause visible ev toExpr viols
+                                  ) [(conj,causes)]  -- the motivation for these actions
+                                | clause@(Dnf antcs conss) <- dnfClauses
+                                , let expr    = dnf2expr clause
+                                , let sgn     = sign expr -- different dnf clauses may have different signatures
+                                , let clause' = conjNF (subst (dcl, actSem ev dcl (delta (sign dcl))) expr)
+                                , let step    = conjNF (notCpl expr .\/. clause')
+                                , let viols   = conjNF (notCpl clause')
+                                , let negs    = foldr (./\.) (EDcV sgn) antcs
+                                , let poss    = foldr (.\/.) (notCpl (EDcV sgn)) conss
+                                , let frExpr  = if ev==Ins
+                                                then conjNF negs
+                                                else conjNF poss
+                                , dcl `elem` relsUsedIn frExpr
+                                , let toExpr = if ev==Ins
+                                               then conjNF poss
+                                               else conjNF (notCpl negs)
+                                ]
+                                [(conj,causes)]  -- to supply motivations on runtime
+                          | conjEq <- eqCl snd3 [(dnfClauses,conj,rule) | (_,dnfClauses,conj,rule)<-relEq]
+                          , let causes               = nub (map thd3 conjEq)
+                          , let (dnfClauses,conj,_) = head conjEq
+                          ]
+                          [(conj,nub [r |(_,_,_,r)<-cl]) | cl<-eqCl thd4 relEq, let (_,_,conj,_) = head cl]  -- to supply motivations on runtime
+          ]
+       fst4 (w,_,_,_) = w
+       snd3 (_,y,_) = y
+       thd3 (_,_,z) = z
+       thd4 (_,_,z,_) = z
+
+-- If one rule r blocks upon an event, e.g. e@(ON Ins rel), while another ECA rule r'
+-- maintains something else with that same event e, we can save r' the trouble.
+-- After all, event e will block anyway.
+-- preEmpt tries to simplify ECArules by predicting whether a rule will block.
+   preEmpt :: [ECArule] -> [ECArule]
+   preEmpt ers = pr [length ers] (10::Int)
+    where
+     pr :: [Int] -> Int -> [ECArule]
+     pr ls n
+       | n == 0              = fatal 633 $ "too many cascading levels in preEmpt "++show ls
+       | (not.null) cascaded = pr (length cascaded:ls)
+                               -- ([er{ecaAction=normPA (ecaAction er)} | er<-cascaded] ++uncasced)
+                                  (n-1)
+       | otherwise           = [er{ecaAction=normPA (ecaAction er)} | er<-uncasced]
+      where
+-- preEmpt divides all ECA rules in uncascaded rules and cascaded rules.
+-- cascaded rules are those rules that have a Do component with event e, where e is known to block (for some other reason)
+       new  = [er{ecaAction=normPA (ecaAction er)} | er<-ers]
+       cascaded = [er{ecaAction=action'} | er<-new, let (c,action') = cascade (eDcl (ecaTriggr er)) (ecaAction er), c]
+       uncasced = [er |                    er<-new, let (c,_)       = cascade (eDcl (ecaTriggr er)) (ecaAction er), not c]
+-- cascade inserts a block on the place where a Do component exists that matches the blocking event.
+--     cascade :: Relation -> PAclause -> (Bool, PAclause)
+     cascade dcl (Do srt to _ _) | (not.null) blkErs = (True, ecaAction (head blkErs))
+      where blkErs = [er | er<-ers
+                         , Blk _<-[ecaAction er]
+                         , let t = ecaTriggr er
+                         , eSrt t == srt
+                         , eDcl t == to
+                         , not (dcl ==to)
+                         ]
+     cascade  _  c@Do{}           = (False, c)
+     cascade rel (New c clause m) = ((fst.cascade rel.clause) "dummystr", New c (snd.cascade rel.clause) m)
+     cascade rel (Rmv c clause m) = ((fst.cascade rel.clause) "dummystr", Rmv c (snd.cascade rel.clause) m)
+     cascade rel (Sel c e cl m)   = ((fst.cascade rel.cl) "dummystr",     Sel c e (snd.cascade rel.cl)   m)
+     cascade rel (CHC ds m)       = (any (fst.cascade rel) ds, CHC (map (snd.cascade rel) ds) m)
+     cascade rel (ALL ds m)       = (any (fst.cascade rel) ds, ALL (map (snd.cascade rel) ds) m)
+     cascade  _  (Nop m)          = (False, Nop m)
+     cascade  _  (Blk m)          = (False, Blk m)
+     cascade  _  (Let _ _ _)  = fatal 611 "Deze constructor is niet gedefinieerd" -- HJO, 20131205:Toegevoegd om warning te verwijderen
+     cascade  _  (Ref _)      = fatal 612 "Deze constructor is niet gedefinieerd" -- HJO, 20131205:Toegevoegd om warning te verwijderen
+        
+   conjuncts :: Rule -> [DnfClause]
+   conjuncts = map disjuncts.exprIsc2list.conjNF.rrexp
+   disjuncts :: Expression -> DnfClause
+   disjuncts conj = (split (Dnf [] []).exprUni2list) conj
+    where split :: DnfClause -> [Expression] -> DnfClause
+          split (Dnf antc cons) (ECpl e: rest) = split (Dnf (e:antc) cons) rest
+          split (Dnf antc cons) (     e: rest) = split (Dnf antc (e:cons)) rest
+          split dc             []             = dc
+
+   -- | Action semantics for inserting a delta into a relation dcl.
+   actSem :: InsDel -> Declaration -> Expression -> Expression
+   actSem Ins dcl e@(EDcD d) | dcl==d        = EDcD dcl
+                             | otherwise     = EDcD dcl .\/. e
+   actSem Ins dcl delt | sign dcl/=sign delt = fatal 598 "Type error in actSem Ins"
+                       | otherwise           = disjNF (EDcD dcl .\/. delt)
+   actSem Del dcl e@(EDcD d) | dcl==d        = notCpl (EDcV (sign d))
+                             | otherwise     = EDcD dcl ./\. notCpl e
+   actSem Del dcl delt | sign dcl/=sign delt = fatal 603 "Type error in actSem Del"
+                       | otherwise           = conjNF (EDcD dcl ./\. notCpl delt)
+
+   delta :: Sign -> Expression
+   delta sgn
+    = EDcD   Sgn { decnm   = "Delta"
+                 , decsgn  = sgn
+                 , decprps = []
+                 , decprps_calc = Nothing
+                 , decprL  = ""
+                 , decprM  = ""
+                 , decprR  = ""
+                 , decMean = AMeaning [ A_Markup Dutch   ReST (string2Blocks ReST "TODO: Doel van deze Delta relatie opschrijven")
+                                      , A_Markup English ReST (string2Blocks ReST "TODO: Write down the purpose of this Delta relation.")
+                                      ]
+                 , decConceptDef = Nothing
+                 , decfpos = Origin ("generated relation (Delta "++show sgn++")")
+                 , decissX = True
+                 , decusrX = False
+                 , decISA = False
+                 , decpat  = ""
+                 , decplug = True
+                 } 
+
+   -- | de functie genPAclause beschrijft de voornaamste mogelijkheden om een expressie delta' te verwerken in expr (met tOp'==Ins of tOp==Del)
+-- TODO: Vind een wetenschappelijk artikel waar de hier beschreven transformatie uitputtend wordt behandeld.
+-- TODO: Deze code is onvolledig en misschien zelfs fout....
+   genPAclause :: (Declaration->Bool)        -- ^True if a relation may be changed (i.e. is editable)
+                  -> InsDel                  -- ^the type of action: Insert or Delete
+                  -> Expression              -- ^the expression in which a delete or insert takes place
+                  -> Expression              -- ^the delta to be inserted or deleted
+                  -> [(Expression,[Rule])]   -- ^the motivation, consisting of the conjuncts (traced back to their rules) that are being restored by this code fragment.
+                  -> PAclause
+   genPAclause editAble tOp' expr1 delta1 motive = genPAcl delta1 tOp' expr1 motive
+    where
+      genPAcl deltaX tOp exprX motiv =
+        case (tOp, exprX) of
+          (_ ,  EFlp x)     -> genPAcl (flp deltaX) tOp x motiv
+          (_ ,  EBrk x)     -> genPAcl deltaX tOp x motiv
+          (Ins, ECpl x)     -> genPAcl deltaX Del x motiv
+          (Del, ECpl x)     -> genPAcl deltaX Ins x motiv
+          (Ins, e@EUni{})   -> CHC [ genPAcl deltaX Ins f motiv | f<-exprUni2list e{-, not (f==expr1 && Ins/=tOp') -}] motiv -- the filter prevents self compensating PA-clauses.
+          (Ins, e@EIsc{})   -> ALL [ genPAcl deltaX Ins f []    | f<-exprIsc2list e ] motiv
+          (Ins, e@ECps{})   -> CHC [ {- the following might be useful for diagnostics:
+                                     if showADL exprX=="project;partof~"
+                                     then fatal 702 ( "Diagnostic error\n"++
+                                                      "chop (exprCps2list e)= "++show [(map showADL ls, map showADL rs)| (ls,rs)<-chop (exprCps2list e) ]++
+                                                      "\nConcepts c="++showADL c++",  target els="++showADL (target els)++",  source ers="++showADL (source ers)++
+                                                      "\nfLft \"x\"= "++showADL (fLft "x") ++
+                                                      "\nfRht \"x\"= "++showADL (fRht "x")
+                                                    )
+                                     else -}
+                                     if els==flp ers
+                                     then CHC [ New c fLft motiv
+                                              , Sel c els fLft motiv
+                                              ] motiv
+                                     else CHC [ New c (\x->ALL [fLft x, fRht x] motiv) motiv
+                                              , Sel c els fLft motiv
+                                              , Sel c (flp ers) fRht motiv
+                                              ] motiv
+                                   | (ls,rs)<-chop (exprCps2list e)
+                                   , let els=foldCompose ls
+                                   , let ers=foldCompose rs
+                                   , let c=source ers  -- SJ 20131202: Note that target ers==source els
+                                   , let fLft atom = genPAcl (disjNF ((EMp1 atom (source ers) .*. deltaX) .\/. notCpl ers)) Ins ers []
+                                   , let fRht atom = genPAcl (disjNF ((deltaX .*. EMp1 atom (target els)) .\/. notCpl els)) Ins els []
+                                   ] motiv
+                               where foldCompose xs = case xs of
+                                                       [] -> fatal 659 "Going into (foldr1 (.:.)) with an empty list"
+                                                       _  -> foldr1 (.:.) xs
+{- Problem: how to insert Delta into r;s
+This corresponds with:  genPAclause editAble Ins (ECps (r,s)) Delta motive
+Let us solve it mathematically,  and gradually transform via pseudo-code into Haskell code.
+The problem is how to find dr and ds such that 
+   Delta \/ r;s  |-  (dr\/r) ; (ds\/s)
+Since r;s  |-  (dr\/r) ; (ds\/s) is true by definition, we simplify:
+   Delta  |-  (dr\/r) ; (ds\/s)
+One way of doing this is the "bow tie" solution, which uses one element, c, and chooses dr = Delta*c  and ds = c*Delta.
+There is a fair chance, however, that this solution breaks existing rules.
+For example, if Delta< has multiple elements and r is injective, we have a violation. (Similarly, if Delta> has multiple elements and s is univalent)
+Since we make no assumptions on the rules that r and s must satisfy, let us look for more subtle solutions.
+For instance, we might choose dr = d;s~  and ds = r~;d, for that part of Delta that is not in r;s (let d = Delta-r;s)
+The approach is to do this first, then see which links are left and connect these last ones with a bow tie approach.
+
+SEQ [ ASSIGN d (EDif (delta,e))
+    , ALL [ FOREACH (x,y) FROM d DO
+              SEQ [ SEL z FROM SELECT (x',z) FROM r WHERE x==x'
+                  , INSERT (z,y) INTO s
+                  ]
+          , FOREACH (x,y) FROM d DO
+              SEQ [ SEL z FROM SELECT (z,y') FROM s WHERE y==y'
+                  , INSERT (x,z) INTO r
+                  ]
+          , SEQ [ ASSIGN delta' [ (x,y) | (x,y)<-d, x `notElem` dom e, y `notElem` cod e]
+                , CHC [ NEW z IN target r `meet` source s
+                      , SEL z FROM contents (target r `meet` source s)
+                      ]
+                , INSERT [ (z,y) | (x,y)<-delta' ] INTO s
+                , INSERT [ (x,z) | (x,y)<-delta' ] INTO r
+                ]
+          ]
+    ]
+
+On this algorithm, there are some attractive optimizations. 
+Some code generation can be prevented, when we know that r or s are not editable.
+Generation of a SEL statement can be prevented, when we know that r is univalent or s is injective.
+
+This is what becomes of it:
+
+SEQ [ ASSIGN d (EDif (delta,e))
+    , COMMENT "Variable d contains only those links that need to be inserted into e."
+    , CONDITIONAL not (null d)
+      (ALL((if editable s
+            then [ COMMENT "The following statement inserts tuples only on the right side of the composition."
+                 , FOREACH (x,y) FROM d DO
+                    SEQ [ if injective s
+                          then            SELECT (x',z) FROM r WHERE x==x'
+                          else SEL z FROM SELECT (x',z) FROM r WHERE x==x'
+                        , INSERT (z,y) INTO s
+                        ]
+                 ]
+            else [] )++
+           (if editable r
+            then [ COMMENT "The following statement inserts tuples only on the left side of the composition."
+                 , FOREACH (x,y) FROM d DO
+                    SEQ [ if injective s
+                          then            SELECT (z,y') FROM s WHERE y==y'
+                          else SEL z FROM SELECT (z,y') FROM s WHERE y==y'
+                        , INSERT (x,z) INTO r
+                        ]
+                 ]
+            else [] )++
+           (if editable r && editable s
+            then [ COMMENT "All links that can be added just in r or just in s have now been added. Now we finish the rest with a bow tie."
+                 , COMMENT "The following statement inserts tuples both on the left and the right side of the composition."
+                 , SEQ [ ASSIGN delta' [ (x,y) | (x,y)<-d, x `notElem` dom e, y `notElem` cod e]
+                       , CHC [ NEW z IN target r `meet` source s
+                             , SEL z FROM contents (target r `meet` source s)
+                             ]
+                       , INSERT [ (z,y) | (x,y)<-delta' ] INTO s
+                       , INSERT [ (x,z) | (x,y)<-delta' ] INTO r
+                       ]
+                 ]
+            else [] )))
+    ]
+
+We can use an "Algebra of Imperative Programs" to move towards real code. Suppose we have the following data structure of imperative programs:
+data Program = SEQ [Program]               -- execute programs in sequence
+             | CONDITIONAL Cond Program    -- evaluate the computation (Cond), which yields a boolean result, and execute the program if it is true
+             | CHC [Program]               -- execute precisely one program from the list
+             | ALL [Program]               -- execute all programs in arbitrary order (may even be parallel)
+             | New String Concept Program  -- create a named variable (the String) of type C (the concept) and execute the program, which may use this concept.
+             | NewAtom PHPRel Concept      -- assign a brand new atom of type Concept to the PHPRel, which must be a PHPvar (i.e. a variable).
+             | ASSIGN PHPRel PHPExpression -- execute a relation expression in PHP and assign its result to the PHPRel, which must be a PHPvar (i.e. a variable).
+             | Insert PHPExpression DBrel  -- execute the computation and insert its result into the database
+             | Delete PHPExpression DBrel  -- execute the computation and delete its result from the database
+             | COMMENT String              -- ignore this. This is part of the algebra, so we can generate commented code.
+             | Nop                         -- do nothing
+             | Blk [(Expression,[Rule])]   -- abort, leaving an error message that motivates this. The motivation consists of the conjuncts (traced back to their rules) that are being restored by this code fragment.
+data Cond    = NotNull PHPRel  -- a condition on a PHPRel
+
+In order to proceed to the next refinement, we have enriched the PHPExpression data structure with variables (PHPvar) and queries (PHPqry) 
+We need a variable in PHP that represents a relation, which gets the label PHPvar.
+We also need to query an Expression on the SQL server. The result of that query is relation contents in PHP, which gets the label PHPqry.
+The 'almost Haskell' program fragment for generating an insertion of Delta into r;s is now:
+let delta = PHPvar{ phpVar = "delta"       -- this is the input
+                  , phptyp = phpsign (sign e)    -- the type is used nowhere, but it feels good to know the type.
+                  } in
+let d     = PHPvar{ phpVar = "d"           -- this is the input, from which everything already in  Ecps es  is removed.
+                  , phptyp = phpsign (sign e)    -- the type is used nowhere, but it feels good to know the type.
+                  } in
+let newAtoms = [ NewAtom (PHPvar (head (name c):show i) c | (r,s,i)<-zip3 (init es) (tail es) [1..], let c=target(r) `meet` source(s)] in
+SEQ [ ASSIGN d (PHPEDif (PHPERel delta, PHPRel (PHPqry e)))    -- let d = Delta - e0;e1;e2;...
+    , COMMENT "d contains all links that must be inserted in r;s"
+    , CONDITIONAL (NotNull d)
+      (SEQ [ ALL ( (if editable(head es)    
+                    then [ Insert (PHPECps [PHPERel d, PHPERel (PHPqry (flp (ECps (tail es))))]) (mkDBrel (head es)) ]
+                    else []) ++
+                   (if editable(last es)
+                    then [ Insert (PHPECps [PHPERel (PHPqry (flp (ECps (init es)))), PHPERel d]) (mkDBrel (last es)) ]
+                    else []) )
+           , COMMENT "All links that can be added just in r or just in s have now been added. Now we finish the rest with a bow tie."] ++
+           if or [not (editable e) | e<-es] || or [ not (editable (I c)) | NewAtom _ c<-newAtoms ]  then [] else
+           [ -- let us see which links are left to be inserted
+             ASSIGN d (PHPEDif (PHPERel d, PHPRel (PHPqry (ECps es))))
+           , COMMENT "d contains the remaining links to be inserted in r;s"
+           , CONDITIONAL (NotNull d)
+             (SEQ ( newAtoms ++
+                    ALL ( let vs = [ v | NewAtom v _ <- newAtoms ] in
+                          [ Insert (PHPEPrd [PHPERel d, PHPERel (PHPvar (head vs))]) (mkDBrel (head es)) ]++
+                          [ Insert (PHPEprd [PHPERel cl, PHPERel cr]) (mkDBrel e) | (cl,cr,e)<-zip (init vs) (tail vs) tail (init es))] ++
+                          [ Insert (PHPEPrd [PHPERel (PHPvar (last vs)), PHPERel d]) (mkDBrel (last es)) ])
+             )    )
+           ]
+      )
+    ]
+
+In order to proceed to the real code, we must realize that mkDBrel is not defined yet.
+The argument of mkDBrel is an Expression. This can be an ERel{} or something different.
+In case it is an ERel{}, the insert can be translated directly to a database action.
+If it is not, the insert can be treated as a recursive call to genPAcl, which breaks down the expression further until it reaches a relation.
+let delta = PHPvar{ phpVar = "delta"       -- this is the input
+                  , phptyp = phpsign (sign e)    -- the type is used nowhere, but it feels good to know the type.
+                  } in
+let d     = PHPvar{ phpVar = "d"           -- this is the input, from which everything already in  Ecps es  is removed.
+                  , phptyp = phpsign (sign e)    -- the type is used nowhere, but it feels good to know the type.
+                  } in
+let newAtoms = [ NewAtom (PHPvar (head (name c):show i) c | (r,s,i)<-zip3 (init es) (tail es) [1..], let c=target(r) `meet` source(s)] in
+SEQUENCE [ ASSIGN d (PHPEDif (PHPERel delta, PHPRel (PHPqry (ECps es))))
+         , COMMENT "d contains all links to be inserted in r;s"
+         , CONDITIONAL (NotNull d)
+           (SEQUENCE([ ALL ( (if editable(head es)
+                              then [ if isRel (head es)
+                                     then Insert (PHPECps (PHPERel d, PHPERel (PHPqry (flp (ECps (tail es)))))) (let PHPRel r = head es in r)
+                                     else genPAclause editAble Ins (head es) (PHPECps [PHPERel d, PHPERel (PHPqry (flp (ECps (tail es))))]) motive
+                                   ]
+                              else []) ++
+                             (if editable(last es)
+                              then [ if isRel (last es)
+                                     then Insert (PHPECps [PHPERel (PHPqry (flp (ECps (init es)))), PHPERel d]) (let PHPRel r = last es in r)
+                                     else genPAclause editAble Ins (last es) (PHPECps [PHPERel (PHPqry (flp (ECps (init es)))), PHPERel d]) motive
+                                   ]
+                              else []) )
+                     , COMMENT "All links that can be added just in r or just in s have now been added. Now we finish the rest with a bow tie."] ++
+                     if or [not (editable e) | e<-es] || or [ not (editable (I c)) | NewAtom _ c<-newAtoms ]  then [] else
+                     [ -- let us see which links are left to be inserted
+                       ASSIGN d (PHPEDif (PHPERel d, PHPRel (PHPqry (ECps es))))
+                     , COMMENT "d contains the remaining links to be inserted in r;s"
+                     , CONDITIONAL (NotNull d)
+                       (SEQ ( newAtoms ++
+                              ALL ( let vs = [ v | NewAtom v _ <- newAtoms ] in
+                                    [ if isRel (head es)
+                                      then Insert (PHPEPrd [PHPERel d, PHPERel (PHPvar (head vs))]) (let PHPRel r = head es in r)
+                                      else genPAclause editAble Ins (head es) (PHPEPrd [PHPERel d, PHPERel (PHPvar (head vs))]) motive]++
+                                    [ Insert (PHPEprd [PHPERel cl, PHPERel cr]) (mkDBrel e) | (cl,cr,e)<-zip (init vs) (tail vs) tail (init es))] ++
+                                    [ if isRel (last es)
+                                      then Insert (PHPEPrd [PHPERel (PHPvar (last vs)), PHPERel d]) (let PHPRel r = last es in r)
+                                      else genPAclause editAble Ins (last es) (PHPEPrd [PHPERel d, PHPERel (PHPvar (head vs))]) motive ])
+                       )    )
+                     ])
+           )
+         ]
+
+-}
+          (Del, e@ECps{})   -> CHC [ if els==flp ers
+                                     then CHC [ Sel c (disjNF els) (\_->Rmv c fLft motiv) motiv
+                                              , Sel c (disjNF els) fLft motiv
+                                              ] motiv
+                                     else CHC [ Sel c (disjNF (els ./\. flp ers)) (\_->Rmv c (\x->ALL [fLft x, fRht x] motiv) motiv) motiv
+                                              , Sel c (disjNF (els ./\. flp ers)) fLft motiv
+                                              , Sel c (disjNF (els ./\. flp ers)) fRht motiv
+                                              ] motiv
+                                   | (ls,rs)<-chop (exprCps2list e)
+                                   , let ers=foldCompose rs
+                                   , let els=foldCompose ls
+                                   , let c=source ers  -- SJ 20131202: Note that target ers==source els
+                                   , let fLft atom = genPAcl (disjNF ((EMp1 atom (source ers) .*. deltaX) .\/. notCpl ers)) Del ers []  -- TODO (SJ 26-01-2013) is this double code?
+                                   , let fRht atom = genPAcl (disjNF ((deltaX .*. EMp1 atom (target els)) .\/. notCpl els)) Del els []
+                                   ] motiv
+                               where foldCompose xs = case xs of
+                                                       [] -> fatal 851 "Going into (foldr1 (.:.)) with an empty list"
+                                                       _  -> foldr1 (.:.) xs
+{- Purpose: how to delete Delta from ECps es
+This corresponds with:  genPAclause editAble Del (ECps es) Delta motive
+One way of doing this is to select from es one subexpression, e, that is editable.
+By removing the proper links from that particular e, all chains are broken.
+
+Splitting the terms on one particular subexpression can be done as follows:
+  triples = [ (take i es, es!!i, drop (i+1) es) | i<-[0..length es-1]  ]
+This gives us triples, (left,e,right), each of which is a candidate for deletion.
+There is no point in having two candidates, (left,e,right) and (left',e',right'), with e==e'.
+Since e and e' are aliases of the underlying database relation, deletion from e need not be repeated by deletion from e'.
+That is why double candidates may be excluded. Here is how:
+  triples = [ (take i es, es!!i, drop (i+1) es) | i<-[0..length es-1], es!!i `notElem` (take i es)  ]
+If e is a relation and editable as well, this relation can be used for deletion.
+The elements from e to be deleted are those, that establish a link between cod(left) and dom(right).
+In order to eliminate these, no link from the expression  left~;e;right~  may survive.
+If we sum up the alternatives in pseudocode, we get:
+CHC [ DELETE ((ECps (reverse (map flp left) ++ [e] ++ reverse (map flp right))) FROM e
+    | (left,ERel e _,right)<-triples
+    , editable e ]
+In order to refine further to real code, we must realize that deletion can be done in relations only. Not in expressions.
+So if e is a relation, the DELETE can be executed.
+If it is an expression, the function genPAclause can be called recursively.
+We now get the following code fragment:
+CHC [ if isRel e
+      then DELETE (ECps (reverse (map flp left) ++ [e] ++ reverse (map flp right))) FROM  (let PHPRel r = e in r)
+      else genPAclause editAble Del e (ECps (reverse (map flp left) ++ [e] ++ reverse (map flp right))) motive
+    | (left,ERel e _,right)<-triples
+    , editable e ]
+
+-}
+          (Del, e@EUni{}) -> ALL [ genPAcl deltaX Del f []    | f<-exprUni2list e {-, not (f==expr1 && Del/=tOp') -}] motiv -- the filter prevents self compensating PA-clauses.
+          (Del, e@EIsc{}) -> CHC [ genPAcl deltaX Del f motiv | f<-exprIsc2list e ] motiv
+-- Op basis van De Morgan is de procesalgebra in het geval van (Ins, ERad ts)  afleidbaar uit uit het geval van (Del, ECps ts) ...
+          (_  , e@ERad{}) -> genPAcl deltaX tOp (deMorganERad e) motiv
+          (_  , EPrd{})   -> fatal 896 "TODO"
+          (_  , EKl0 x )  -> genPAcl (deltaK0 deltaX tOp x) tOp x motiv
+          (_  , EKl1 x )  -> genPAcl (deltaK1 deltaX tOp x) tOp x motiv
+          (_  , e@(EDcD d)) -> -- fatal 742 ("DIAG ADL2Fspec 764:\ndoCod ("++showADL deltaX++") "++show tOp++" ("++showADL exprX++"),\n"
+                                   -- -- ++"\nwith disjNF deltaX:\n "++showADL (disjNF deltaX))
+                                 if editAble d then Do tOp d deltaX motiv else Blk [(e, nub [r |(_,rs)<-motiv, r<-rs])]
+
+-- HJO, 20130423: *LET OP!! De volgende code is er bij gefreubeld om geen last te hebben van de fatal767, maar is niet goed. *****
+-- Dit is in overleg met Stef, die deze hele code toch compleet wil herzien, i.v.m. de nieuwe typechecker.
+-- SJC, 20131012: Dan lijkt me dit een goed moment om deze regel weer uit te commentaren, aangezien ik nu de typechecker aan het herzien ben
+--   ik doe dit even met een fatal ipv `echt' commentaar
+-- SJ 20131117: I think not. Refactoring of this generator is nigh, though holding uppe other developments cannot be tolerated! So ye following code shall remain wrong rather than fatal... Long live the King!  ^_^ 
+          (_ , e@EDcV{}) -> Blk [(e, nub [r |(_,rs)<-motiv, r<-rs])]
+          (_ , _)        -> fatal 767 ( "(Stef?) Non-exhaustive patterns in the recursive call\n"
+                                       ++"doCod ("++showADL deltaX++") -- deltaX\n      "++show tOp++"  -- tOp\n      ("++showADL exprX++") -- exprX\n"++
+                                         "within function\ndoCode "++show tOp'++"  -- tOp'\n       ("++showADL expr1++") -- expr1\n       ("++showADL delta1++") -- delta1\n"++
+                                         concat
+                                         [ "while trying to maintain conjunct "++showADL conjunct++
+                                           "\nfrom rule "++intercalate "\n          " [show r | r<-rs]
+                                         | (conjunct,rs)<-motive ] ++
+                                         if null motive then "null motive" else ""
+                                         )
+
+   switchboard :: Options -> Fspc -> Fswitchboard
+   switchboard flags fSpec
+    = Fswtch
+       { fsbEvIn  = eventsIn
+       , fsbEvOut = eventsOut
+       , fsbConjs = conjs
+       , fsbECAs  = ecas
+       }
+      where
+        qs :: [Quad]
+        qs        = quads flags visible (invariants fSpec)
+        ecas      = assembleECAs qs
+        conjs     = nub [ (cl_rule ccrs,rc_conjunct x) | Quad _ ccrs<-qs, x<-cl_conjNF ccrs]
+        eventsIn  = nub [ecaTriggr eca | eca<-ecas ]
+        eventsOut = nub [On tOp dcl | eca<-ecas, doAct<-dos (ecaAction eca), let Do tOp e _ _=doAct, EDcD dcl<-[EDcD e, flp $ EDcD e]] -- TODO (SJ 26-01-2013) silly code: ERel rel _<-[ERel e (sign e), flp $ ERel e (sign e)] Why is this?
+        visible _ = True
+
+-- Auxiliaries
+   chop :: [a] -> [([a], [a])]
+   chop xs = [ splitAt i xs | i <- [1..length xs-1]]
+   
+   deltaK0 :: t -> InsDel -> t1 -> t
+   deltaK0 delta' Ins _ = delta'  -- error! (tijdelijk... moet berekenen welke paren in x gezet moeten worden zodat delta |- x*)
+   deltaK0 delta' Del _ = delta'  -- error! (tijdelijk... moet berekenen welke paren uit x verwijderd moeten worden zodat delta/\x* leeg is)
+   deltaK1 :: t -> InsDel -> t1 -> t
+   deltaK1 delta' Ins _ = delta'  -- error! (tijdelijk... moet berekenen welke paren in x gezet moeten worden zodat delta |- x+)
+   deltaK1 delta' Del _ = delta'  -- error! (tijdelijk... moet berekenen welke paren uit x verwijderd moeten worden zodat delta/\x+ leeg is)
+
+   
+   class Identified a => Rename a where
+    rename :: a->String->a
+    -- | the function uniqueNames ensures case-insensitive unique names like sql plug names
+    uniqueNames :: [String]->[a]->[a]
+    uniqueNames taken xs
+     = [p | cl<-eqCl (map toLower.name) xs  -- each equivalence class cl contains (identified a) with the same map toLower (name p)
+          , p <-if name (head cl) `elem` taken || length cl>1
+                then [rename p (name p++show i) | (p,i)<-zip cl [(1::Int)..]]
+                else cl
+       ]
+
+   instance Rename PlugSQL where
+    rename p x = p{sqlname=x}
+
+ src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/ADL2Plug.hs view
@@ -0,0 +1,422 @@+{-# OPTIONS_GHC -Wall #-}  
+module DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Plug 
+  (makeGeneratedSqlPlugs
+  ,makeUserDefinedSqlPlug 
+  )
+where
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (sortWith)
+import DatabaseDesign.Ampersand.Core.Poset as Poset hiding (sortWith)
+import Prelude hiding (Ord(..),head)
+import DatabaseDesign.Ampersand.Basics
+import DatabaseDesign.Ampersand.Classes
+import DatabaseDesign.Ampersand.ADL1
+import DatabaseDesign.Ampersand.Fspec.Plug
+import DatabaseDesign.Ampersand.Misc
+import DatabaseDesign.Ampersand.Fspec.ShowHS --for debugging
+import Data.Maybe
+import Data.Char
+import Data.List (nub,intercalate,partition)
+import GHC.Exts (sortWith)
+
+--import Debug.Trace  
+-- Dummy trace function.
+trace :: String -> a -> a  
+trace _ a = a
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Fspec.ToFspec.ADL2Plug"
+
+head :: Int -> [a] -> a
+head i [] = fatal i "head must not be used on an empty list!"
+head _ (a:_) = a
+
+
+makeGeneratedSqlPlugs :: Options
+              -> A_Context
+              -> [Expression]  
+              -> [Declaration]    -- ^ declarations to be saved in generated database plugs. 
+              -> [PlugSQL]
+makeGeneratedSqlPlugs flags context totsurs entityDcls = gTables
+  where
+        vsqlplugs = [ (makeUserDefinedSqlPlug context p) | p<-ctxsql context] --REMARK -> no optimization like try2specific, because these plugs are user defined
+        gTables = gPlugs ++ gLinkTables
+        gPlugs :: [PlugSQL]
+        gPlugs   = trace ("---\nStart makeEntityTables with "++show (length entityDcls)++" declarations and "++show(length vsqlplugs)++" userdefined plugs.\n") 
+                         (makeEntityTables flags entityDcls (ctxgs context) (ctxgenconcs context) (declsUsedIn vsqlplugs))
+        -- all plugs for relations not touched by definedplugs and gPlugs
+        gLinkTables :: [PlugSQL]
+        gLinkTables = [ makeLinkTable dcl totsurs
+                      | dcl<-entityDcls
+                      , Inj `notElem` multiplicities dcl
+                      , Uni `notElem` multiplicities dcl]
+
+
+-----------------------------------------
+--makeLinkTable
+-----------------------------------------
+-- makeLinkTable creates associations (BinSQL) between plugs that represent wide tables.
+-- Typical for BinSQL is that it has exactly two columns that are not unique and may not contain NULL values
+--
+-- this concerns relations that are not univalent nor injective, i.e. flduniq=False for both columns
+-- Univalent relations and injective relations cannot be associations, because they are used as attributes in wide tables.
+-- REMARK -> imagine a context with only one univalent relation r::A*B.
+--           Then r can be found in a wide table plug (TblSQL) with a list of two columns [I[A],r], 
+--           and not in a BinSQL with a pair of columns (I/\r;r~, r)
+--
+-- a relation r (or r~) is stored in the trgFld of this plug
+
+
+-- | Make a binary sqlplug for a relation that is neither inj nor uni
+makeLinkTable :: Declaration -> [Expression] -> PlugSQL
+makeLinkTable dcl totsurs = 
+  case dcl of
+    Sgn{} 
+     | Inj `elem` multiplicities dcl || Uni `elem` multiplicities dcl 
+        -> fatal 55 $ "unexpected call of makeLinkTable("++show dcl++"), because it is injective or univalent."
+     | otherwise 
+        -> BinSQL
+             { sqlname = name dcl
+             , columns = ( -- The source field:
+                           Fld { fldname = srcNm                       
+                               , fldexpr = srcExpr
+                               , fldtype = makeSqlType (target srcExpr)
+                               , flduse  = ForeignKey (target srcExpr)
+                               , fldnull = isTot trgExpr
+                               , flduniq = isUni trgExpr
+                               } 
+                         , -- The target field:
+                           Fld { fldname = trgNm                       
+                               , fldexpr = trgExpr
+                               , fldtype = makeSqlType (target trgExpr)
+                               , flduse  = ForeignKey (target trgExpr)
+                               , fldnull = isSur trgExpr
+                               , flduniq = isInj trgExpr
+                               }
+                          ) 
+             , cLkpTbl = [] --in case of TOT or SUR you might use a binary plug to lookup a concept (don't forget to nub)
+             , mLkp    = trgExpr
+          --   , sqlfpa  = NO
+             }
+    _  -> fatal 90 "Do not call makeLinkTable on relations other than Rel{}"
+   where
+    r_is_Tot = Tot `elem` multiplicities dcl || dcl `elem` [ d |       EDcD d  <- totsurs]
+    r_is_Sur = Sur `elem` multiplicities dcl || dcl `elem` [ d | EFlp (EDcD d) <- totsurs]
+    srcNm = (if isEndo dcl then "s" else "")++name (source trgExpr)
+    trgNm = (if isEndo dcl then "t" else "")++name (target trgExpr)
+    --the expr for the source of r
+    srcExpr
+     | r_is_Tot = EDcI (source dcl)
+     | r_is_Sur = EDcI (target dcl)
+     | otherwise = let er=EDcD dcl in EDcI (source dcl) ./\. (er .:. flp er)
+    --the expr for the target of r
+    trgExpr 
+     | not r_is_Tot && r_is_Sur = flp (EDcD dcl)
+     | otherwise                = EDcD dcl
+
+-----------------------------------------
+--rel2fld
+-----------------------------------------
+-- Each relation yields one field f1 in the plug...
+-- r is the relation from some kernel field k1 to f1
+-- (fldexpr k1) is the relation from the plug's imaginary ID to k1
+-- (fldexpr k1);r is the relation from ID to f1
+-- the rule (fldexpr k1)~;(fldexpr k1);r = r holds because (fldexpr k1) is uni and sur, which means that (fldexpr k1)~;(fldexpr k1) = I
+-- REMARK -> r may be tot or sur, but not inj. (fldexpr k1) may be tot.
+--
+-- fldnull and fldunique are based on the multiplicity of the relation (kernelpath);r from ID to (target r)
+-- it is given that ID is unique and not null
+-- fldnull=not(isTot (kernelpath);r)
+-- flduniq=isInj (kernelpath);r
+-- 
+-- (kernel++plugAtts) defines the name space, making sure that all fields within a plug have unique names.
+
+-- | Create field for TblSQL or ScalarSQL plugs 
+rel2fld :: [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 kernel
+        plugAtts
+        e
+        
+ = Fld { fldname = fldName 
+       , fldexpr = e
+       , fldtype = makeSqlType (target e)
+       , flduse  =  
+          let f expr =
+                 case expr of
+                    EDcI c   -> PrimKey c
+                    EDcD _   -> PlainAttr
+                    EFlp e'  -> f e'
+                    _        -> fatal 144 ("No flduse defined for "++show expr)
+          in f e
+       , fldnull = maybenull e
+       , flduniq = isInj e      -- all kernel fldexprs are inj
+                                -- Therefore, a composition of kernel expr (I;kernelpath;e) will also be inj.
+                                -- It is enough to check isInj e
+       }
+   where 
+   fldName = case [nm | (r',nm)<-table, e==r'] of 
+               []   -> fatal 117 $ "null names in table for e: " ++ show (e,table)
+               n:_  -> n
+     where 
+       table :: [(Expression, String)]
+       table   = [ entry
+                 | cl<-eqCl (map toLower.niceidname) (kernel++plugAtts)
+                 , entry<-if length cl==1 then [(rel,niceidname rel) |rel<-cl] else tbl cl]
+       tbl rs  = [ entry
+                 | cl<-eqCl (map toLower.name.source) rs
+                 , entry<-if length cl==1
+                          then [(rel,niceidname rel++name (source rel)) |rel<-cl]
+                          else [(rel,niceidname rel++show i)|(rel,i)<-zip cl [(0::Int)..]]]
+       niceidname (EFlp x) = niceidname x
+       niceidname (EDcD d) = name d
+       niceidname (EDcI c) = name c
+       niceidname rel      = fatal 162 ( "Unexpected relation found:\n"++
+                                        intercalate "\n  "
+                                        [ "***rel:"
+                                        , show rel
+                                        , "***kernel:"
+                                        , show kernel
+                                        , "***plugAtts:"
+                                        , show plugAtts
+                                        ]
+                                    )
+   --in a wide table, m can be total, but the field for its target may contain NULL values,
+   --because (why? ...)
+   --A kernel field may contain NULL values if
+   --  + its field expr is not total OR
+   --  + its field expr is not the identity relation AND the (kernel) field for its source may contain NULL values
+   --(if the fldexpr of a kernel field is the identity, 
+   -- then the fldexpr defines the relation between this kernel field and this kernel field (fldnull=not(isTot I) and flduniq=isInj I)
+   -- otherwise it is the relation between this kernel field and some other kernel field)
+   maybenull expr
+    | length(map target kernel) > length(nub(map target kernel))
+       = fatal 146 $"more than one kernel field for the same concept:\n    expr = " ++(show expr)++
+           intercalate "\n  *** " ( "" : (map (name.target) kernel)) 
+    | otherwise = case expr of
+                   EDcD dcl
+                        | (not.isTot) dcl -> True
+                        | otherwise -> (not.null) [()|k<-kernelpaths, target k==source dcl && isTot k || target k==target dcl && isSur k ]
+                   EFlp (EDcD dcl)
+                        | (not.isSur) dcl -> True
+                        | otherwise -> (not.null) [()|k<-kernelpaths, target k==source dcl && isSur k || target k==target dcl && isTot k]
+                   EDcI _ -> False
+                   _ -> fatal 152 ("Illegal Plug Expression: "++show expr ++"\n"++
+                                   " ***kernel:*** \n   "++
+                                   intercalate "\n   " (map show kernel)++"\n"++
+                                   " ***Attributes:*** \n   "++
+                                   intercalate "\n   " (map show plugAtts)++"\n"++
+                                   " ***e:*** \n   "++
+                                   ( show e)
+                                  )
+                                   
+                                   
+   kernelpaths = clos kernel
+    where
+     -- Warshall's transitive closure algorithm, adapted for this purpose:
+     clos :: [Expression] -> [Expression]
+     clos xs
+      = [ foldr1 (.:.) expr | expr<-exprList ]
+        where
+         exprList :: [[Expression]]
+      -- SJ 20131117. The following code (exprList and f) assumes no ISA's in the A-structure. Therefore, this works due to the introduction of EEps.
+         exprList = foldl f [[x] | x<-nub xs]
+                          (nub [c | c<-nub (map source xs), c'<-nub (map target xs), c==c'])
+         f :: [[Expression]] -> A_Concept -> [[Expression]]
+         f q x = q ++ [ls ++ rs | ls <- q, x == target (last ls)
+                                , rs <- q, x == source (head 233 rs), null (ls `isc` rs)]
+                  
+-- ^ Explanation:  rel is a relation from some kernel field k to f
+-- ^ (fldexpr k) is the relation from the plug's ID to k
+-- ^ (fldexpr k);rel is the relation from ID to f
+
+-----------------------------------------
+--makeEntityTables  (formerly called: makeTblPlugs)
+-----------------------------------------
+{- makeEntityTables computes a set of plugs to obtain tables in a transactional database with minimal redundancy.
+   We call them "wide tables".
+   makeEntityTables computes entities with their attributes.
+   It is based on the principle that each concept is represented in at most one plug,
+   and each relation in at most one plug.
+   First, we determine the kernels for all plugs.
+   A kernel contains the concept table(s) for all concepts that are administered in the same entity.
+   For that, we collect all relations that are univalent, injective, and surjective (the kernel relations).
+      By the way, that includes all isa-relations, since they are univalent, injective, and surjective by definition.
+      Since isa-relations are not declared explicitly, they are generated separately.
+   If two concepts a and b are in the same entity, there is a concept g such that a isa g and b isa g.
+   Of all concepts in an entity, one most generic concept is designated as root, and is positioned in the first column of the table.
+   Secondly, we take all univalent relations that are not in the kernel, but depart from this kernel.
+   These relations serve as attributes. Code:  [a| a<-attRels, source a `elem` concs kernel]
+   Then, all these relations are made into fields. Code: plugFields = [rel2fld plugMors a| a<-plugMors]
+   We also define two lookup tables, one for the concepts that are stored in the kernel, and one for the attributes of these concepts.
+   For the fun of it, we sort the plugs on length, the longest first. Code:   sortWith ((0-).length.fields)
+   By the way, parameter allRels contains all relations that are declared in context, enriched with extra multiplicities.
+   This parameter allRels was added to makePlugs to avoid recomputation of the extra multiplicities.
+   The parameter exclusions was added in order to exclude certain concepts and relations from the process.
+-}
+-- | Generate non-binary sqlplugs for relations that are at least inj or uni, but not already in some user defined sqlplug
+makeEntityTables :: Options 
+                -> [Declaration] -- ^ all relations in scope
+                -> [A_Gen]
+                -> [[A_Concept]] -- ^ concepts `belonging' together.
+                                 --   for each class<-conceptss: c,c'<-class:   c `join` c' exists (although there is not necessarily a concept d=c `join` c'    ...)
+                -> [Declaration] -- ^ relations that should be excluded, because they wil not be implemented using generated sql plugs. 
+                -> [PlugSQL]
+makeEntityTables flags allDcls isas conceptss exclusions
+ = sortWith ((0-).length.plugFields)
+    (map kernel2Plug kernelsWithAttributes)
+   where
+    diagnostics
+      = "\nallDcls:" ++     concat ["\n  "++showHSName r           | r<-allDcls]++
+        "\nallDcls:" ++     concat ["\n  "++showHS flags "\n  " r  | r<-allDcls]++
+        "\nconceptss:" ++   concat ["\n  "++showHS flags "    " cs | cs<-conceptss]++
+        "\nexclusions:" ++  concat ["\n  "++showHSName r           | r<-exclusions]++
+        "\nattRels:" ++     concat ["\n  "++showHS flags "    " e  | e<-attRels]++
+        "\n"
+    rootss = map (rootConcepts isas) conceptss
+    kernels = [ nub (roots++concat [ smallerConcepts isas c | c <- roots ])
+              | roots<-rootss ]
+    kernelsWithAttributes = dist attRels kernels []
+      where 
+        dist :: (Association attrib, Show attrib) => [attrib] -> [[A_Concept]] -> [([A_Concept], [attrib])] -> [([A_Concept], [attrib])]
+        dist []   []     result = result
+        dist atts []     _      = fatal 246 ("No kernel found for atts: "++show atts++"\n"++diagnostics)
+        dist atts (kernel:ks) result = dist otherAtts ks ([(kernel,attsOfK)] ++ result)
+           where (attsOfK,otherAtts) = partition belongsInK atts
+                 belongsInK att = source att `elem` kernel
+    -- | converts a kernel into a plug
+    kernel2Plug :: ([A_Concept],[Expression]) -> PlugSQL
+    kernel2Plug (kernel, attsAndIsaRels)
+     =  TblSQL 
+             { sqlname = name (head 289 (head 288 conceptss)) -- ++ " !!Let op: De ISA relaties zie ik hier nergens terug!! (TODO. HJO 20131201"
+             , fields  = map fld plugMors      -- Each field comes from a relation.
+             , cLkpTbl = conceptLookuptable
+             , mLkpTbl = attributeLookuptable ++ isaLookuptable
+             } 
+        where
+          (isaAtts,atts) = partition isISA attsAndIsaRels
+            where -- isISA (EDcD r) = decISA r
+                  isISA (EDcI _) = True
+                  isISA _        = False
+          mainkernel = map EDcI kernel
+          plugMors :: [Expression]
+          plugMors = mainkernel++atts 
+          conceptLookuptable :: [(A_Concept,SqlField)]
+          conceptLookuptable    = [(target r,fld r) | r <-mainkernel]
+          attributeLookuptable :: [(Expression,SqlField,SqlField)]
+          attributeLookuptable  = -- kernel attributes are always surjective from left to right. So do not flip the lookup table!
+                                  [(e,lookupC (source e),fld e) | e <-plugMors] 
+          lookupC cpt           = if null [f |(c',f)<-conceptLookuptable, cpt==c'] 
+                                  then fatal 209 "null cLkptable."
+                                  else (head 301) [f |(c',f)<-conceptLookuptable, cpt==c']
+          fld a                 = rel2fld mainkernel atts a
+          isaLookuptable = [(e,lookupC (source e),lookupC (target e)) | e <- isaAtts ]    
+-- attRels contains all relations that will be attribute of a kernel.
+-- The type is the largest possible type, which is the declared type, because that contains all atoms (also the atoms of subtypes) needed in the operation.
+    attRels :: [Expression]
+    attRels = mapMaybe attExprOf (allDcls>- exclusions)
+    attExprOf :: Declaration -> Maybe Expression
+    attExprOf d =
+     case d of  --make explicit what happens with each possible decl...
+       Isn{} -> Nothing -- These relations are already in the kernel
+       Vs{}  -> Nothing -- Vs are not implemented at all
+       Sgn{} ->
+            case (isInj d, isUni d, isSur d, isTot d) of
+                 (False  , False  , _      , _      ) --Will become a link-table
+                     -> Nothing 
+                 (False  , True   , _      , _      )
+                     -> Just $      EDcD d
+                 (True   , False  , _      , _      )
+                     -> Just $ flp (EDcD d)
+                 (True   , True   , False  , False  )
+                     -> Just $      EDcD d
+                 (True   , True   , False  , True   ) --Equivalent to CLASSIFY t ISA s, however, it is named, so it must be stored in a plug!
+                     -> Just $      EDcD d
+                 (True   , True   , True   , False  ) --Equivalent to CLASSIFY s ISA t, however, it is named, so it must be stored in a plug!
+                     -> Just $ flp (EDcD d)
+                 (True   , True   , True   , True   ) --An interesting relation indeed. However, it must be implemented, for it is relevant: i.e. `successor` relation on weekdays.
+                     -> Just $      EDcD d
+
+
+
+-----------------------------------------
+--makeUserDefinedSqlPlug
+-----------------------------------------
+--makeUserDefinedSqlPlug is used to make user defined plugs. One advantage is that the field names and types can be controlled by the user. 
+--
+--TODO151210 -> (see also Instance Object PlugSQL)
+--              cLkpTbl TblSQL{} can have more than one concept i.e. one for each kernel field
+--              a kernel may have more than one concept that is uni,tot,inj,sur with some imaginary ID of the plug (i.e. fldnull=False)
+--              When is an ObjectDef a ScalarPlug or BinPlug?
+--              When do you want to define your own Scalar or BinPlug
+--rel2fld  (identities context) kernel plugAtts r
+
+-- | Make a sqlplug from an ObjectDef (user-defined sql plug)
+makeUserDefinedSqlPlug :: A_Context -> ObjectDef -> PlugSQL
+makeUserDefinedSqlPlug _ obj
+ | null(objatsLegacy obj) && isIdent(objctx obj)
+    = ScalarSQL { sqlname   = name obj
+                , sqlColumn = rel2fld [EDcI c] [] (EDcI c)
+                , cLkp      = c
+                } 
+ | null(objatsLegacy obj) --TODO151210 -> assuming objctx obj is Rel{} if it is not I{}
+   = fatal 2372 "TODO151210 -> implement defining binary plugs in ASCII"
+ | isIdent(objctx obj) --TODO151210 -> a kernel may have more than one concept that is uni,tot,inj,sur with some imaginary ID of the plug
+   = {- The following may be useful for debugging:
+     error 
+      ("\nc: "++show c++
+       "\nrels:"++concat ["\n  "++show r | r<-rels]++
+       "\nkernel:"++concat ["\n  "++show r | r<-kernel]++
+       "\nattRels:"++concat ["\n  "++show e | e<-attRels]++
+       "\nplugfields:"++concat ["\n  "++show plugField | plugField<-plugfields]
+      ) -}
+     TblSQL { sqlname = name obj
+            , fields  = plugfields
+            , cLkpTbl = conceptLookuptable     
+            , mLkpTbl = attributeLookuptable
+            }   
+ | otherwise = fatal 279 "Implementation expects one concept for plug object (SQLPLUG tblX: I[Concept])."
+  where       
+   c   -- one concept from the kernel is designated to "lead" this plug, this is user-defined.
+     = source(objctx obj) 
+   rels --fields are user-defined as one deep objats with objctx=r. note: type incorrect or non-relation objats are ignored
+     = [(objctx att,sqltp att) | att<-objatsLegacy obj, source (objctx att)==c]   
+   kernel --I[c] and every non-endo r or r~ which is at least uni,inj,sur are kernel fields 
+          --REMARK -> endo r or r~ which are at least uni,inj,sur are inefficient in a way
+          --          if also TOT than r=I => duplicates, 
+          --          otherwise if r would be implemented as GEN (target r) ISA C then (target r) could become a kernel field
+     = [(EDcI c,sqltp obj)] 
+       ++ [(r,tp) |(r,tp)<-rels,not (isEndo r),isUni r, isInj r, isSur r]
+       ++ [(r,tp) |(r,tp)<-rels,not (isEndo r),isUni r, isInj r, isTot r, not (isSur r)]
+   attRels --all user-defined non-kernel fields are attributes of (rel2fld (objctx c))
+     = (rels >- kernel) >- [(flp r,tp) |(r,tp)<-kernel] --note: r<-rels where r=objctx obj are ignored (objctx obj=I)
+   plugMors              = kernel++attRels
+   plugfields            = [fld r tp | (r,tp)<-plugMors] 
+   fld r tp              = (rel2fld (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           = if null [f |(c',f)<-conceptLookuptable, cpt==c'] 
+                           then fatal 300 "null cLkptable."
+                           else (head 377) [f |(c',f)<-conceptLookuptable, cpt==c']
+   sqltp :: ObjectDef -> SqlType
+   sqltp att = (head 379) $ [makeSqltype' sqltp' | strs<-objstrs att,('S':'Q':'L':'T':'Y':'P':'E':'=':sqltp')<-strs]
+                      ++[SQLVarchar 255]
+
+makeSqlType :: A_Concept -> SqlType
+makeSqlType ONE = SQLBool -- TODO (SJ):  Martijn, why should ONE have a representation? Or should this rather be a fatal?
+makeSqlType c = makeSqltype' (cpttp c)
+makeSqltype' :: String -> SqlType
+makeSqltype' str = case str of
+       ('V':'a':'r':'c':'h':'a':'r':_) -> SQLVarchar 255 --TODO number
+       "Pass" -> SQLPass
+       ('C':'h':'a':'r':_) -> SQLChar 255 --TODO number
+       "Blob" -> SQLBlob
+       "Single" -> SQLSingle
+       "Double" -> SQLDouble
+       ('u':'I':'n':'t':_) -> SQLuInt 4 --TODO number
+       ('s':'I':'n':'t':_) -> SQLsInt 4 --TODO number
+       "Id" -> SQLId 
+       ('B':'o':'o':'l':_) -> SQLBool
+       "" -> SQLVarchar 255
+       _ -> fatal 335 ("Unknown type: "++str)
+ src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/Calc.hs view
@@ -0,0 +1,558 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Fspec.ToFspec.Calc
+            ( deriveProofs 
+            , lambda
+            , checkMono
+            , showProof, showPrf
+          --  , testInterface
+            )
+where
+
+   import DatabaseDesign.Ampersand.Basics         (fatalMsg,Collection (isc),Identified(..),eqCl)
+   import Data.List hiding (head)
+   import GHC.Exts (sortWith)
+   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (sortWith)
+   import DatabaseDesign.Ampersand.ADL1
+   import DatabaseDesign.Ampersand.ADL1.Expression                 (subst,isNeg)
+   import DatabaseDesign.Ampersand.Classes
+   import DatabaseDesign.Ampersand.Fspec.Fspec (Fspc(..),Clauses(..),RuleClause(..),Quad(..),ECArule(..),InsDel(..),PAclause(..), DnfClause(..), dnf2expr)
+   import DatabaseDesign.Ampersand.Fspec.ShowADL (ShowADL(..))
+   import DatabaseDesign.Ampersand.Fspec.ShowECA (showECA)
+   import DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Fspec
+   import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms        (conjNF,disjNF,cfProof,dfProof,nfProof,simplify,normPA,exprIsc2list, exprUni2list, exprCps2list, exprRad2list) --,proofPA) -- proofPA may be used to test derivations of PAclauses.
+   import DatabaseDesign.Ampersand.Misc            (Lang(..),Options(..),PandocFormat(ReST),string2Blocks)
+   import Text.Pandoc
+   import Prelude hiding (head)
+   
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Fspec.ToFspec.Calc"
+
+   head :: [a] -> a
+   head [] = fatal 30 "head must not be used on an empty list!"
+   head (a:_) = a
+
+-- testInterface :: Fspc -> Interface -> String
+-- Deze functie is bedoeld om te bedenken hoe interfaces moeten worden afgeleid uit een vers vertaalde ObjectDef.
+-- Nadat deze goed werkt kunnen de bewijsgenerator en de codegenerator worden gemaakt.
+--   testInterface :: Options -> Fspc -> Interface -> String
+--   testInterface flags fSpec ifc
+--    = "\nInterface "++ name ifc++"("++intercalate ", " [showADL r++":"++name (target r) | r<-rels]++")\n"++
+--      " - The parameters correspond to editable fields in a user interface.\n   "++
+--      showADL ifc++"\n"++
+--      " - Invariants:\n   "++intercalate "\n   " [showADL rule    | rule<-invs]++"\n"++
+--      " - Derivation of clauses for ECA-rules:"   ++
+--      concat [showClause fSpec (allClauses flags rule) | rule<-invs]++"\n"++
+--{-
+--      " - ECA rules:"++concat  [ "\n\n   "++showECA fSpec "\n>     "  (eca{ecaAction=normPA (ecaAction eca)})
+--                                 ++"\n------ Derivation ----->"++showProof (showECA fSpec "\n>     ") (proofPA (ecaAction eca))++"\n<------End Derivation --"
+--                               | eca<-ecaRs]++"\n\n"++
+---}
+--      " - Visible relations:\n   "++intercalate "\n   " (spread 80 ", " [showADL r  | r<-vis])++"\n"
+--    where
+----        showQ i (rel, shs,conj,r)
+----         = "\nQuad "++show i++":\nrelation: "++showADL rel++":\nshifts: "++concat ["\n"++showADLe s |s<-shs]++"\nconjunct: "++showADL conj++"\nrule: "++showADL r++""
+----TODO: Deze code komt ook voor in ADL2Fspec.hs. Dat lijkt dubbelop, en derhalve niet goed.
+--        rels = nub (recur (ifcObj ifc))
+--         where recur obj = [editMph (objctx o) | o<-objatsLegacy obj, editable (objctx o)]++[r | o<-objatsLegacy obj, r<-recur o]
+--        vis        = nub (rels++map (I . target) rels)
+--   --     visible r  = r `elem` vis
+--        invs       = [rule | rule<-invariants fSpec, (not.null) (map makeDeclaration (relsUsedIn rule) `isc` vis)]
+--   --     qs         = vquads fSpec
+--   --     ecaRs      = assembleECAs qs
+----        editable (ERel Rel{} _)  = True    --WHY?? Stef, welke functie is de juiste?? TODO deze functie staat ook in ADL2Fspec.hs, maar is daar ANDERS(!)...
+----        editable _               = False
+----        editMph (ERel r@Rel{} _) = r       --WHY?? Stef, welke functie is de juiste?? TODO deze functie staat ook in ADL2Fspec.hs, maar is daar ANDERS(!)...
+----        editMph e                = fatal 64 $ "cannot determine an editable declaration in a composite expression: "++show e
+--        -- De functie spread verspreidt strings over kolommen met een breedte van n.
+--        -- Deze functie garandeert dat alle strings worden afgedrukt in de aangegeven volgorde.
+--        -- Hij probeert daarbij zo weinig mogelijk regels te gebruiken,
+--        -- en alleen de grens van n te overschrijden als een string zelf langer is dan n.
+--        spread :: Int -> String -> [String] -> [String]
+--        spread n str = f ""
+--         where f stored []       = [stored | not (null stored)]
+--               f [] (cs:css)     = f cs css
+--               f stored (cs:css) | length stored > n = stored: f cs css
+--                                 | length new   <= n = f new css 
+--                                 | otherwise         = stored: f cs css
+--                                   where new = stored++str++cs
+
+   deriveProofs :: Options -> Fspc -> [Inline]
+   deriveProofs flags fSpec
+    = [ Str ("Rules and their conjuncts for "++name fSpec), LineBreak
+      ] ++
+--   conjuncts = map disjuncts.exprIsc2list.conjNF.rrexp
+      intercalate [LineBreak,Str "-- next rule ------------", LineBreak]
+        [ [ Str "rule r:   ", Str (showADL r), LineBreak]++
+          [ Str "rrexp r:  ", Str (showADL (rrexp r)), LineBreak]++
+          [ Str "conjNF:   ", Str (showADL (conjNF (rrexp r))), LineBreak]++
+          intercalate [LineBreak] [ [Str "     conj: ", Str (showADL conj)] | conj<-conjuncts r]
+        | r<-grules fSpec++vrules fSpec] ++
+      [ --"\nSignals for "++name fSpec++"\n--------------\n"++
+        --proof (signals fSpec)++
+        LineBreak
+      , Str ("Transformation of user specified rules into ECA rules for "++name fSpec)
+      , LineBreak, Str "--------------", LineBreak, Str "--------------", LineBreak
+      , LineBreak, Str "First step: determine all (", Str (show (length qs)), Str ") quads", LineBreak
+      , LineBreak, Str "-- first quad ------------", LineBreak
+      ]
+      ++
+      intercalate [LineBreak,Str "-- next quad ------------",LineBreak]
+        [ [            Str "When relation ", Str (showADL rel), Str " is changed,"
+          , LineBreak, Str (showADL r)
+          ]++ (if length (cl_conjNF ccrs)<=1 then [Space] else [Str " (", Str (show (length (cl_conjNF ccrs))), Str " conjuncts)"]) ++
+          [ Str " must be restored.", LineBreak, Str "This quad has conjunct: ", Str (showADL (rc_conjunct x))
+          , Str " and ", Str (show (length (rc_dnfClauses x))), Str " dnf clauses."
+          ]++
+          [ inl
+          | dc<-(rc_dnfClauses x), inl<-[LineBreak, Str "Dnf clause ", Str (showADL dc)]]
+        | Quad rel ccrs<-qs, let r=cl_rule ccrs , x<-cl_conjNF ccrs ]
+      ++
+      [ LineBreak, Str "-- end ------------", LineBreak, LineBreak, Str "Second step: assemble dnf clauses."
+      , LineBreak, Str "-- first dnf clause ------------", LineBreak]
+      ++
+      intercalate [LineBreak,Str "-- next dnf clause ------------",LineBreak]
+        [ [ Str "Dnf clause ", Str (showADL dc)
+          , LineBreak, Str "is derived from rule ", Str (showADL r)
+          , LineBreak
+          , Str ( case ms of
+                  []    -> "no relations affect this clause"
+                  [rel] -> "It can be called when relation " ++showADL rel++" is affected."
+                  _     -> "It can be called when relations "++commaEng "or" [showADL rel | rel<-ms]++" are affected."
+                )
+          ]
+          | (ms,dc,r)<-
+              [ (nub [ dcl |(dcl,_,_)<-cl],dc,r)
+              | cl<-eqCl (\(_,_,dc)->dc) [(dcl,dc,r) |Quad dcl ccrs<-qs, let r=cl_rule ccrs, x<-cl_conjNF ccrs, dc<-rc_dnfClauses x]
+              , let (_,dc,r) = head cl
+              ]
+         ]
+      ++
+      [ LineBreak, Str "-- end ------------", LineBreak, LineBreak, Str "Third step: determine ECA rules"] ++
+      [ if verboseP flags
+        then Str " (Turn --verbose off if you want to see ECA rules only)"
+        else Str " (Turn on --verbose if you want to see more detail)" ] ++
+      [ LineBreak ]
+      ++
+      concat
+        [ [ LineBreak,Str "-- ECA Rule ", Str (show (ecaNum ecarule)), Str " ---------", LineBreak
+          , Str (showECA fSpec "\n  " ecarule{ecaAction=normPA (ecaAction ecarule)}) ]++
+          concat [ [ LineBreak, Str "delta expression", LineBreak, Space, Str (showADL d)
+                   , LineBreak, Str "derivation:"
+                   , LineBreak, Space]++
+                   (showProof showADL. nfProof showADL) d ++  -- nfProof produces its result in disjunctive normal form
+                   [ LineBreak, Str "disjunctly normalized delta expression" 
+                   , LineBreak, Str (showADL (disjNF d))
+                   ]
+                 | verboseP flags, e@Do{}<-[ecaAction ecarule], let d = paDelta e ]
+        | ecarule <- ecaRs]
+      ++
+      [ LineBreak, Str "--------------", LineBreak, LineBreak, Str "Fourth step: cascade blocking rules"
+      , LineBreak
+      ]++
+      intercalate []
+        [ [LineBreak, Str ("-- Raw ECA rule "++show (ecaNum er)++"------------"), LineBreak, Str (showECA fSpec "\n  " er)]
+        | er<- ecaRs]
+      ++
+      [ LineBreak, Str "--------------", LineBreak, LineBreak, Str "Fifth step: preEmpt the rules (= optimize)"
+      , LineBreak
+      ]++
+{- TODO: readdress preEmpt. It is wrong
+      intercalate []
+        [ [LineBreak, Str ("-- Preempted ECA rule "++show (ecaNum er)++"------------"), LineBreak, Str (showECA fSpec "\n  " er)]
+        | er<- preEmpt ecaRs]
+      ++ -}
+      [ Str "--------------", LineBreak, Str "Final step: derivations --------------", LineBreak]
+      ++
+      intercalate [LineBreak, Str "--------------", LineBreak]
+         [ derivation rule
+         | rule<-udefrules fSpec]++
+      [Str ("Aantal Rules: "++(show.length.udefrules) fSpec)]
+{-
+      ++
+      [ LineBreak, Str "--------------", LineBreak]
+      ++ -- TODO: make an ontological analysis, which explains the delete behaviour.
+      [ Str "Ontological analysis: ", LineBreak, Str "  "]
+      ++
+      intercalate [LineBreak, LineBreak, Str "  "] 
+          [ [Str (name ifc), Str "("]
+            ++ intercalate [Str ", "] 
+                 [[Str (name a), Str "[", Str ((name.target.ctx) a), Str "]"]
+                 |a<-attributes (ifcObj ifc)]
+            ++ [Str "):", LineBreak, Str "  "]
+          | ifc<-interfaceS fSpec]
+      ++
+      [ LineBreak, Str "--------------", LineBreak
+      , Str "Analyzing interfaces:", LineBreak, Str "     "]
+      ++
+      intercalate [LineBreak, Str "     "] 
+         [[Str (testInterface flags fSpec ifc)]
+         | ifc<-take 1 (interfaceG fSpec)]
+      ++
+      [ LineBreak, Str "--------------", LineBreak]
+      -}
+      where 
+  --     visible _  = True -- We take all quads into account.
+       qs         = vquads fSpec  -- the quads that are derived for this fSpec specify dnf clauses, meant to maintain rule r, to be called when relation rel is affected (rel is in r).
+          --   assembleECAs :: (Relation Concept->Bool) -> [Quad] -> [ECArule]
+       ecaRs      = assembleECAs qs  -- this creates all ECA rules from the available quads. They are still raw (unoptimized).
+
+  --     relEqCls = eqCl fst4 [(rel,dnfClauses,conj,cl_rule ccrs) | Quad rel ccrs<-qs, (conj,dnfClauses)<-cl_conjNF ccrs]
+--  This is what ADL2Fpsec has to say about computing ECA rules:
+--       ecas
+--        = [ ECA (On ev rel) delt act
+--          | relEq <- relEqCls                 -- The material required for one relation
+--          , let (rel,_,_,_) = head relEq      -- This is the relation
+--          , let ERel delt _ = delta (sign rel)  -- delt is a placeholder for the pairs that have been inserted or deleted in rel.
+--          , ev<-[Ins,Del]                     -- This determines the event: On ev rel
+--          , let act = ALL [ CHC [ (if isTrue  clause' || isTrue  step   then Nop else
+--                                   if isFalse clause'   then Blk else
+----                                 if not (visible rel) then Blk else
+--                                   let visible _ = True in genPAclause visible ev toExpr viols)
+--                                   [(conj,causes)]  -- the motivation for these actions
+--                                | dc@(Dnf antcs conss) <- dnfClauses
+--                                , let clause  = dnf2expr dc
+--                                , let sgn     = sign clause
+--                                , let clause' = conjNF (subst (rel, actSem Ins rel (delta (sign rel))) clause)
+--                                , let step    = conjNF (notCpl clause .\/. clause')
+--                                , let viols   = conjNF (notCpl clause')
+--                                , let negs    = EUni [notCpl f | f<-antcs]
+--                                , let poss    = EUni conss
+--                                , let frExpr  = if ev==Ins
+--                                                then conjNF negs
+--                                                else conjNF poss
+--                                , rel `elem` relsUsedIn frExpr
+--                                , let toExpr = if ev==Ins
+--                                               then conjNF poss
+--                                               else conjNF (notCpl negs)
+--                                ]
+--                                [(conj,causes)]  -- to supply motivations on runtime
+--                          | conjEq <- eqCl snd3 [(dnfClauses,conj,rule) | (_,dnfClauses,conj,rule)<-relEq]
+--                          , let causes          = nub (map thd3 conjEq)
+--                          , let (dnfClauses,conj,_) = head conjEq
+--                          ]
+--                          [(conj,nub [r |(_,_,_,r)<-cl]) | cl<-eqCl thd4 relEq, let (_,_,conj,_) = head cl]  -- to supply motivations on runtime
+--          ]
+--       fst4 (w,_,_,_) = w
+--       snd3 (_,y,_) = y
+--       thd3 (_,_,z) = z
+--       thd4 (_,_,z,_) = z
+       --TODO: See ticket #105
+       derivation :: Rule -> [Inline]
+       derivation rule 
+         = [Str (showADL rule)]++
+           ( if exx'==e
+             then [Str " is already in conjunctive normal form", LineBreak]
+             else [LineBreak, Str "Convert into conjunctive normal form", LineBreak] ++ showProof showADL ((e,[],"<=>"):prf)
+           )++
+           [ LineBreak, Str "Violations are computed by (disjNF . ECpl . normexpr) rule:\n     " ]++
+           (disjProof. notCpl. rrexp) rule++[ LineBreak, LineBreak ] ++
+           concat [ [LineBreak, Str "Conjunct: ", Space, Space, Space, Space, Space, Str (showADL (rc_conjunct x))]++
+                    concat [ [LineBreak, Str "This conjunct has ", Str (show (length (rc_dnfClauses x))), Str " clauses:"] | length (rc_dnfClauses x)>1 ]++
+                    concat [ [LineBreak, Str "   Clause: ", Str (showADL clause)] | clause<-(rc_dnfClauses x)]++[ LineBreak]++
+                    concat [ [LineBreak, Str "For each clause, let us analyse the insert- and delete events."] | length (rc_dnfClauses x)>1 ]++
+                    concat [ [LineBreak, Str "   Clause: ", Str (showADL clause), Str " may be affected by the following events:",LineBreak]++
+                             concat [ [Str "event = ", Str (show ev), Space, Str (showADL dcl), Str " means doing the following substitution", LineBreak ] ++
+                                      [Str (showADL clause++"["++showADL dcl++":="++showADL (actSem ev dcl (delta (sign dcl)))++"] = clause'"), LineBreak ] ++
+                                      [Str ("clause' = "++showADL ex'), LineBreak ] ++
+                                      concat [ [Str ("which has CNF: "++showADL ex'), LineBreak] | clause'/=ex'] ++
+                                      [Str ("Computing the violations means to negate the conjunct: "++showADL (notClau)), LineBreak ] ++
+                                      concat [ [Str ("which has CNF: "++showADL viols), LineBreak] | notClau/=viols] ++
+                                      [Str "Now try to derive whether clause |- clause' is true... ", LineBreak, Str (showADL (notClau .\/. clause')), LineBreak, Str "<=>", LineBreak, Str (showADL step), LineBreak ]
+                                    | dcl <-relsUsedIn r
+                                    , ev<-[Ins,Del]
+                                    , let ex'     = subst (dcl, actSem ev dcl (delta (sign dcl))) expr
+                                    , let clause' = conjNF ex'
+                                    , let notClau = notCpl clause'
+                                    , let step    = conjNF (notClau .\/. clause')
+                                    , let viols   = conjNF (notClau)
+                                    , let negs    = foldr (./\.) (EDcV sgn) antcs
+                                    , let poss    = foldr (.\/.) (notCpl (EDcV sgn)) conss
+                                    , let frExpr  = if ev==Ins
+                                                    then conjNF negs
+                                                    else conjNF poss
+                                    , dcl `elem` relsUsedIn frExpr
+                        --            , let toExpr = if ev==Ins
+                        --                           then conjNF poss
+                        --                           else conjNF (notCpl negs)
+                                    ]
+                           | clause@(Dnf antcs conss) <- rc_dnfClauses x
+                           , let expr = dnf2expr clause, let sgn = sign expr ]
+                  | let Clauses ts r = allClauses flags rule, x <-ts] ++
+           [LineBreak]
+{-
+           [ Str ("Available code fragments on rule "++name rule++":", LineBreak ]++
+           intercalate [LineBreak] [showADL rule++ " yields\n"++intercalate "\n\n"
+                                   [ [Str "event = ", Str (show ev), Space, Str (showADL rel), LineBreak ] ++
+                                     [Str (showADL r++"["++showADL rel++":="++showADL (actSem ev rel (delta (sign rel)))++"] = r'"), LineBreak ] ++
+                                     [Str "r'    = "] ++ conjProof r' ++ [LineBreak ] ++
+                                     [Str "viols = r'-"] ++ disjProof (ECpl r') ++ [ LineBreak ] ++
+                                     "violations, considering that the valuation of "++showADL rel++" has just been changed to "++showADL (actSem ev rel (delta (sign rel)))++
+                                     "            "++conjProof (ECpl r) ++"\n"++
+                                     "reaction? evaluate r |- r' ("++(showADL.conjNF) (notCpl r .\/. r')++")"++
+                                        conjProof (notCpl r .\/. r')++"\n"++
+                                     "delta: r-/\\r' = "++conjProof (EIsc[notCpl r,r'])++
+                                     "\nNow compute a reaction\n(isTrue.conjNF) (notCpl r .\/. r') = "++show ((isTrue.conjNF) (notCpl r .\/. r'))++"\n"++
+                                     (if null (lambda ev (ERel rel ) r)
+                                      then "lambda "++showADL rel++" ("++showADL r++") = empty\n"
+                                      else -- for debug purposes:
+                                           -- "lambda "++show ev++" "++showADL rel++" ("++showADL r++") = \n"++(intercalate "\n\n".map showPr.lambda ev (ERel rel)) r++"\n"++
+                                           -- "derivMono ("++showADL r++") "++show ev++" "++showADL rel++"\n = "++({-intercalate "\n". map -}showPr.derivMono r ev) rel++"\n"++
+                                           -- "\nNow compute checkMono r ev rel = \n"++show (checkMono r ev rel)++"\n"++
+                                           if (isTrue.conjNF) (notCpl r .\/. r')
+                                           then "A reaction is not required, because  r |- r'. Proof:"++conjProof (notCpl r .\/. r')++"\n"
+                                           else if checkMono r ev rel
+                                           then "A reaction is not required, because  r |- r'. Proof:"{-++(showPr.derivMono r ev) rel-}++"NIET TYPECORRECT: (showPr.derivMono r ev) rel"++"\n"  --WHY? Stef, gaarne herstellen...Deze fout vond ik nadat ik het type van showProof had opgegeven.
+                                           else let ERel _ _ = delta (sign rel) in
+                                                "An appropriate reaction on this event is required."
+                                           --     showECA fSpec "\n  " (ECA (On ev rel) delt (genPAclause visible Ins r viols conj [rule]) 0)
+                                     )
+                                   | rel<-nub [x |x<-relsUsedIn r, not (isIdent x)] -- TODO: include proofs that allow: isIdent rel'
+                                   , ev<-[Ins,Del]
+                                   , r'<-[subst (rel, actSem ev rel (delta (sign rel))) r]
+                        --        , viols<-[conjNF (ECpl r')]
+                                   , True ]  -- (isTrue.conjNF) (notCpl r .\/. r')
+                                  | r<-[dc | cs<-[allClauses flags rule], (_,dnfClauses)<-cl_conjNF cs, dc<-dnfClauses]
+                                  ]
+-}
+              where e = rrexp rule
+                    prf = cfProof showADL e
+                    (exx',_,_) = last prf
+               --     conjProof = showProof showADL . cfProof showADL
+                    disjProof = showProof showADL . dfProof showADL
+--                    showPr    = showProof showADL  -- hoort bij de uitgecommentaarde code hierboven...
+       --TODO: See ticket #105
+       commaEng :: String -> [String] -> String
+       commaEng  _  []       = ""
+       commaEng  _  [x]      = x
+       commaEng str [x,y]    = x++" "++str++" "++y
+       commaEng str (x:y:ys) = x++", "++commaEng str (y:ys)
+
+-- Stel we voeren een actie a uit, die een(1) van de volgende twee is:
+--        {r} INS rel INTO expr {r'}       ofwel
+--        {r} DEL rel FROM expr {r'}
+-- Dan toetst checkMono of r|-r' waar is op grond van de afleiding uit derivMono.
+-- Als dat waar is, betekent dat dat invariant r waar blijft wanneer actie a wordt uitgevoerd.
+   checkMono :: Expression
+             -> InsDel
+             -> Declaration
+             -> Bool
+   checkMono expr ev dcl
+     = case ruleType conclusion of
+        Truth -> fatal 247 "derivMono came up with a Truth!"
+        _     -> simplify expr == simplify (antecedent conclusion) &&
+                 simplify (subst (dcl, actSem ev dcl (delta (sign dcl))) expr) ==
+                 simplify (consequent conclusion)
+     where (conclusion,_,_) = last (derivMono expr ev dcl)
+
+
+   type Proof expr = [(expr,[String],String)]
+   reversePrf :: Proof e -> Proof e
+   reversePrf [] = []
+   reversePrf [s] = [s]
+   reversePrf ((r,cs,e'):prf@((r',_ ,_):_)) = init rp++[(r',cs,rev e'),(r,[],"")]
+     where rp = reversePrf prf
+           rev "==>" = "<=="
+           rev "<==" = "==>"
+           rev "-->" = "<--"
+           rev "<--" = "-->"
+           rev x = x
+
+   showProof :: (expr->String) -> Proof expr -> [Inline]
+   showProof shw [(expr,_,_)]        = [ LineBreak, Space, Space, Space, Space, Space, Space, Str (shw expr), LineBreak]
+   showProof shw ((expr,ss,equ):prf) = [ LineBreak, Space, Space, Space, Space, Space, Space, Str (shw expr), LineBreak] ++
+                                       (if null ss  then [ Space, Space, Space, Str equ ] else
+                                        if null equ then [ Str (unwords ss) ] else
+                                        [ Space, Space, Space, Str equ, Str (" { "++intercalate " and " ss++" }") ])++
+                                       showProof shw prf
+                                       --where e'= if null prf then "" else let (expr,_,_):_ = prf in showHS options "" expr 
+   showProof _  []                   = []
+
+   showPrf :: (expr->String) -> Proof expr -> [String]
+   showPrf shw [(expr,_,_)]        = [ "    "++shw expr]
+   showPrf shw ((expr,ss,equ):prf) = [ "    "++shw expr] ++
+                                     (if null ss  then [ equ ] else
+                                      if null equ then [ unwords ss ] else
+                                      [ equ++" { "++intercalate " and " ss++" }" ])++
+                                     showPrf shw prf
+   showPrf _  []                   = []
+
+-- derivMono provides a derivation to prove that (precondition) r is a subset of (postcondition) r'.
+-- This is useful in proving that an action {expr} a {expr'} maintains its invariant, i.e. that  expr|-expr'  holds (proven by monotony properties)
+-- Derivmono gives a derivation only.
+   derivMono :: Expression -> InsDel -> Declaration -> [(Rule, [String], String)]
+   derivMono expr -- preconditie van actie a
+             tOp  -- de actie (Ins of Del)
+             dcl' -- re relatie, zodat de actie bestaat uit INSERT rel' INTO expr of DELETE rel' FROM expr
+    = f (head (lambda tOp (EDcD dcl') expr++[[]])) (start tOp)
+    where
+     f :: [(Expression, [String], whatever)] 
+        -> (Expression, Expression) 
+        -> [(Rule, [String], String)]
+     f [] (_,_) = []
+     f [(e',_,_)] (neg',pos')
+      = [(rule (subst (dcl',neg') e') (subst (dcl',pos') e'),[],"")]
+     f ((e',["invert"],_): prf@((_,_,_):_)) (neg',pos')
+      = (rule (subst (dcl',neg') e') (subst (dcl',pos') e'),["r |- s  <=>  s- |- r-"],"<=>"):
+         f prf (pos',neg')
+     f ((e1,_,_): prf@((e2,_,_):_)) (neg',pos')
+      = (rule (subst (dcl',neg') e1) (subst (dcl',pos') e1),["Monotony of "++showOp e2],"==>"):
+         f prf (neg',pos')
+         
+     start Ins  = (EDcD dcl',EDcD dcl' .\/. delta (sign dcl'))
+     start Del  = (EDcD dcl' ./\. notCpl (delta (sign dcl')),EDcD dcl')
+
+     rule :: Expression -> Expression -> Rule
+     rule neg' pos' | isTrue neg' = Ru { rrnm  = ""
+                                       , rrfps = Origin "rule generated for isTrue neg' by Calc"
+                                       , rrexp = pos'
+                                       , rrmean = AMeaning
+                                                  [A_Markup Dutch   ReST (string2Blocks ReST "Waarom wordt deze regel hier aangemaakt? (In Calc.hs, regel 402)")
+                                                  ,A_Markup English ReST (string2Blocks ReST "Why is this rule created? (In Calc.hs, line 403)")]  --TODO Stef, gaarne de explanations aanvullen/verwijderen. Dank! Han.
+                                       , rrmsg = []
+                                       , rrviol = Nothing
+                                       , rrtyp = sign neg' {- (neg `meet` pos) -}
+                                       , rrdcl = Nothing
+                                       , r_env = ""
+                                       , r_usr = Multiplicity
+                                       , r_sgl = fatal 336 $ "erroneous reference to r_sgl in rule ("++showADL neg'++") |- ("++showADL pos'++")"
+                                       , srrel = fatal 337 $ "erroneous reference to srrel in rule ("++showADL neg'++") |- ("++showADL pos'++")"
+                                       }
+                    | otherwise   = Ru { rrnm  = ""
+                                       , rrfps = Origin "rule generated for not(isTrue neg') by Calc"
+                                       , rrexp = neg' .|-. pos'
+                                       , rrmean = AMeaning
+                                                  [A_Markup Dutch   ReST (string2Blocks ReST "Waarom wordt deze regel hier aangemaakt? (In Calc.hs, regel 332)")
+                                                  ,A_Markup English ReST (string2Blocks ReST "Why is this rule created? (In Calc.hs, line 333)")]  --TODO Stef, gaarne de explanations aanvullen/verwijderen. Dank! Han.
+                                       , rrmsg = []
+                                       , rrviol = Nothing
+                                       , rrtyp = sign neg' {- (neg `meet` pos) -}
+                                       , rrdcl = Nothing
+                                       , r_env = ""
+                                       , r_usr = Multiplicity
+                                       , r_sgl = fatal 352 $ "illegal reference to r_sgl in rule ("++showADL neg'++") |- ("++showADL pos'++")"
+                                       , srrel = fatal 353 $ "illegal reference to srrel in rule ("++showADL neg'++") |- ("++showADL pos'++")"
+                                       }
+     showOp expr' = case expr' of
+                     EEqu{} -> "="
+                     EImp{} -> "|-"
+                     EIsc{} -> "/\\"
+                     EUni{} -> "\\/"
+                     EDif{} -> "-"
+                     ELrs{} -> "/"
+                     ERrs{} -> "\\"
+                     ECps{} -> ";"
+                     ERad{} -> "!"
+                     EPrd{} -> "*"
+                     EKl0{} -> "*"
+                     EKl1{} -> "+"
+                     EFlp{} -> "~"
+                     ECpl{} -> "-"
+                     _      -> ""
+
+{- The purpose of function lambda is to generate a derivation.
+Rewrite rules:
+-r;-s -> -(r!s)
+-}
+   lambda :: InsDel -> Expression 
+                    -> Expression 
+                    -> [Proof Expression]
+   lambda tOp' e' expr' = [reversePrf[(e'',text,op)
+                          | (e'',_,text,op)<-prf]
+                          | prf<-lam tOp' e' expr' ]
+    where
+     lam :: InsDel -> Expression -> Expression ->
+            [[(Expression,Expression -> Expression,[String],String)]]
+     lam tOp e3 expr =
+          case expr of
+             EIsc{}  | e3==expr             -> [[(e3,id,[],"")]]
+                     | length (const' expr)>0 -> [(expr,\_->expr,      [derivtext tOp "mono" (inter' expr) expr],"<--") :prf
+                                                 | prf<-lam tOp e3 (inter' expr)
+                                                 ]
+                     | and [isNeg f |f<-exprIsc2list expr]
+                                            -> let deMrg = deMorganEIsc expr in
+                                               [(expr, deMorganEIsc, [derivtext tOp "equal" deMrg expr],"==") :prf | prf<-lam tOp e3 deMrg]
+                     | or[null p |p<-fPrfs] -> []
+                     | otherwise            -> [(expr,\_->expr,    [derivtext tOp "mono" (first lc) expr],"<--") : lc]
+             EUni{}  | e3==expr             -> [[(e3,id,[],"")]]
+                     | length (const' expr)>0 -> [(expr,\_->expr, [derivtext tOp "mono" (inter' expr) expr],"<--") :prf
+                                                      | prf<-lam tOp e3 (inter' expr)
+                                                      ]
+                     | and [isNeg f |f<-exprUni2list expr]
+                                            -> let deMrg = deMorganEUni expr in
+                                               [(expr, deMorganEUni, [derivtext tOp "equal" deMrg expr],"==") :prf | prf<-lam tOp e3 deMrg]
+                     | or[null p |p<-fPrfs] -> []
+                     | otherwise            -> [(expr,\_->expr,    [derivtext tOp "mono" (first lc) expr],"<--") : lc]
+             ECps{}  | e3==expr             -> [[(e3,id,[],"")]]
+                     | and [isNeg f |f<-exprCps2list expr]
+                                            -> let deMrg = deMorganECps expr in
+                                               [(expr, deMorganECps, [derivtext tOp "equal" deMrg expr],"==")
+                                               :prf
+                                               | prf<-lam tOp e3 deMrg
+                                               ] -- isNeg is nog niet helemaal correct.
+                     | or[null p|p<-fPrfs]  -> []
+                     | otherwise            -> [(expr,\_->expr,    [derivtext tOp "mono" (first lc) expr],"<--"): lc]        
+             ERad{}  | e3==expr             -> [[(e3,id,[],"")]]
+                     | and [isNeg f |f<-exprRad2list expr]
+                                            -> let deMrg = deMorganERad expr in
+                                               [(expr, deMorganERad, [derivtext tOp "equal" deMrg expr],"==") :prf | prf<-lam tOp e3 deMrg] -- isNeg is nog niet helemaal correct.
+                     | or[null p |p<-fPrfs] -> []
+                     | otherwise            -> [(expr,\_->expr,    [derivtext tOp "mono" (first lc) expr],"<--"): lc]
+             EKl0 x                         -> [(expr,\e->EKl0 e,[derivtext tOp "mono" x expr],"<--") :prf   | prf<-lam tOp e3 x]
+             EKl1 x                         -> [(expr,\e->EKl1 e,[derivtext tOp "mono" x expr],"<--") :prf   | prf<-lam tOp e3 x]
+             ECpl x                         -> [(expr,\e->ECpl e,["invert"],"<--") :prf | prf<-lam (inv tOp) e3 x]
+             EBrk x                         -> lam tOp e3 x
+             _                              -> [[(e3,id,[],"")]]
+           where
+               sgn   = sign expr
+               fPrfs = case expr of
+                        EUni{} -> [lam tOp e3 f |f<-exprUni2list expr, isVar f e3]
+                        EIsc{} -> [lam tOp e3 f |f<-exprIsc2list expr, isVar f e3]
+                        ECps{} -> [lam tOp e3 f |f<-exprCps2list expr, isVar f e3]
+                        ERad{} -> [lam tOp e3 f |f<-exprRad2list expr, isVar f e3]
+                        _      -> fatal 428 ("fPrfs  is not defined.Consult your dealer!")
+               lc = longstcomn vars++concat (drop (length rc-1) (sortWith length rc))
+               rc = remainders vars vars
+               vars = map head fPrfs
+               const' e@EUni{} = [f |f<-exprUni2list e, isConst f e3]
+               const' e@EIsc{} = [f |f<-exprIsc2list e, isConst f e3]
+               const' expr'' = fatal 440 $ "'const'("++ show expr''++")' is not defined.Consult your dealer!"
+               inter' e@EUni{} = foldr (.\/.) (notCpl (EDcV sgn)) [f |f<-exprUni2list e, isVar f e3]
+               inter' e@EIsc{} = foldr (./\.) (EDcV sgn) [f |f<-exprIsc2list e, isVar f e3]
+               inter' expr'' = fatal 443 $ "'inter'("++ show expr''++")' is not defined.Consult your dealer!"
+ --      lam tOp e f       = []
+
+  -- longstcomn determines the longest prefix common to all xs in xss.
+     longstcomn :: (Eq a) => [[(a, b, c, d)]] -> [(a, b, c, d)]
+     longstcomn xss | or [null xs | xs<-xss]      = []
+                    | length (eqCl first xss)==1 = head [head prf | prf<-xss]: longstcomn [tail prf | prf<-xss]
+                    | otherwise                  = []
+    -- remainders determines the remainders.
+     remainders :: (Eq a) => [[(a, b, c, d)]] -> [[(a, b, c, d)]] -> [[(a, b, c, d)]]
+     remainders _ xss | or [null xs | xs<-xss]      = xss
+                      | length (eqCl first xss)==1 = remainders xss [tail prf | prf<-xss]
+                      | otherwise                  = xss
+     isConst :: (ConceptStructure a, ConceptStructure b) => a->b->Bool
+     isConst e f = null (relsUsedIn e `isc` relsUsedIn f)
+     isVar :: (ConceptStructure a, ConceptStructure b) => a->b->Bool
+     isVar e f   = not (isConst e f)
+     derivtext :: InsDel -> String -> Expression -> Expression -> String
+     derivtext tOp "invert" e'' expr = sh tOp++showADL e''++" means "++sh (inv tOp)++showADL expr++"."
+     derivtext tOp "mono"    e'' expr = "("++showADL e''++"->"++showADL expr++") is monotonous, so "++sh tOp++showADL e''++" means "++sh tOp++showADL expr++"."
+     derivtext _ str _ _ = str
+     sh :: InsDel -> String
+     sh Ins  = "insert into "
+     sh Del  = "delete from "
+     inv :: InsDel -> InsDel
+     inv Ins = Del
+     inv Del = Ins
+     first :: [(a,b,c,d)] -> a
+     first ((e'',_,_,_):_) = e''
+     first _ = fatal 472 "wrong pattern in first"
+     
+   ruleType :: Rule -> RuleType
+   ruleType r = case rrexp r of
+                 EEqu{} -> Equivalence
+                 EImp{} -> Implication
+                 _      -> Truth
+
+
+ src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/NormalForms.hs view
@@ -0,0 +1,416 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms 
+  (conjNF,disjNF,normPA,nfProof,cfProof,dfProof,proofPA,simplify,exprIsc2list, exprUni2list, exprCps2list, exprRad2list)
+where
+   import DatabaseDesign.Ampersand.Basics
+   import DatabaseDesign.Ampersand.ADL1.ECArule
+   import DatabaseDesign.Ampersand.Classes.Relational 
+   import DatabaseDesign.Ampersand.ADL1.Expression 
+   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+   import DatabaseDesign.Ampersand.Fspec.Fspec
+-- import DatabaseDesign.Ampersand.Fspec.ShowADL  -- for debug purposes only
+   import Data.List (nub {- , intercalate -} )
+--   import Debug.Trace
+   import Prelude hiding (head)
+   
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Fspec.ToFspec.NormalForms"
+
+   head :: [a] -> a
+   head [] = fatal 30 "head must not be used on an empty list!"
+   head (a:_) = a
+
+
+{- Normalization of process algebra clauses -}
+
+   normPA :: PAclause -> PAclause
+   normPA expr = expr' 
+       where (expr',_,_) = if null (proofPA expr) then fatal 21 "last: empty list" else last (proofPA expr)
+
+   type Proof a = [(a, [String], String)]
+
+   proofPA :: PAclause -> Proof PAclause
+   proofPA = {-reverse.take 3.reverse.-}pPA
+    where pPA expr' = case normstepPA expr' of
+                       ( _ , []  ,equ) -> [(expr',[]   ,equ)]    -- is dus (expr,[],"<=>")
+                       (res,steps,equ) -> (expr',steps,equ):pPA res
+
+   normstepPA :: PAclause -> (PAclause,[String],String)
+   normstepPA expr = (res,ss,"<=>")
+    where
+     (res,ss) = norm expr
+     norm :: PAclause -> (PAclause,[String])
+     norm (CHC [] ms)  = (Blk ms, ["Run out of options"])
+     norm (CHC [r] ms) = (r', ["Flatten ONE"])
+                       where r' = case r of
+                                    Blk{} -> r
+                                    _     -> r{paMotiv = ms} 
+-- WHY? Stef, kan je uitleggen wat hier gebeurt? Enig commentaar is hier wel op zijn plaats.
+-- Ook zou het helpen om bij de verschillende constructoren van PAclause een beschrijving te geven van het idee er achter. 
+-- BECAUSE! Kan ik wel uitleggen, maar het is een heel verhaal. Dat moet tzt in een wetenschappelijk artikel gebeuren, zodat het er goed staat.
+-- Het idee is dat een procesalgebra is weergegeven in Haskell combinatoren (gedefinieerd als PAclause(..), zie ADL.ECArule).
+-- Die kun je vervolgens normaliseren met herschrijfregels op basis van gelijkheden die gelden in de bewuste procesalgebra.
+-- Helaas zijn de herschrijfregels nu nog hard gecodeerd, zodat ik voor PAclause een afzonderlijke Haskell functie moet schrijven.
+-- Hierna volgt de normalisator voor relatiealgebra-expressies, genaamd normStep. Die heeft dezelfde structuur,
+-- maar gebruikt herschrijfregels vanuit gelijkheden die gelden in relatiealgebra.
+     norm (CHC ds ms)  | (not.null) msgs = (CHC ops ms, msgs)
+                       | (not.null) [d | d<-ds, isCHC d] = (CHC (nub [ d' | d<-ds, d'<-if isCHC d then let CHC ops' _ = d in ops' else [d] ]) ms, ["flatten CHC"])  -- flatten
+                       | (not.null) [Nop | Nop{}<-ops] = (Nop{paMotiv=ms}, ["Choose to do nothing"])
+                       | (not.null) [Blk | Blk{}<-ops] = (CHC [op | op<-ops, not (isBlk op)] ms, ["Choose anything but block"])
+                       | otherwise = (CHC ds ms, [])
+                       where nds  = map norm ds
+                             msgs = concatMap snd nds
+                             ops  = map fst nds
+     norm (ALL [] ms)  = (Nop ms, ["ALL [] = No Operation"])
+     norm (ALL [d] ms) = (d', ["Flatten ONE"])
+                       where d' = case d of
+                                    Blk{} -> d
+                                    _     -> d{paMotiv = ms} 
+     norm (ALL ds ms)  | (not.null) msgs = (ALL ops ms, msgs)
+                       | (not.null) [d | d<-ds, isAll d] = (ALL (nub [ d' | d<-ds, d'<-if isAll d then let ALL ops' _ = d in ops' else [d] ]) ms, ["flatten ALL"])  -- flatten
+                       | (not.null) [Blk | Blk{}<-ops] = (Blk{paMotiv = [m | op@Blk{}<-ops,m<-paMotiv op]}, ["Block all"])
+                       | (not.null) [Nop | Nop{}<-ops] = (ALL [op | op<-ops, not (isNop op)] ms, ["Ignore Nop"])
+                       | (not.null) long              = (ALL ds' ms, ["Take the expressions for "++commaEng "and" [name (paTo (head cl)) |cl<-long]++"together"])
+                       | otherwise = (ALL ds ms, [])
+                       where ds' = [ let p=head cl in
+                                       if length cl==1 then p else p{paDelta=disjNF (foldr1 (.\/.) [paDelta c | c<-cl]), paMotiv=concatMap paMotiv cl}
+                                   | cl<-dCls {- not (null cl) is guaranteed by eqCl -} ]
+                                   ++[d | d<-ds, not (isDo d)]
+                             nds  = map norm ds
+                             msgs = concatMap snd nds
+                             ops  = map fst nds
+                             dCls :: [[PAclause]]
+                             dCls = eqCl to [d | d<-ds, isDo d]
+                             long :: [[PAclause]]
+                             long = [cl | cl<-dCls, length cl>1]
+                             to d@Do{} = (paSrt d,paTo d)
+                             to _        = fatal 74 "illegal call of to(d)"
+     norm (New c p ms)        = ( case p' of
+                                   Blk{} -> p'{paMotiv = ms}
+                                   _     -> New c (\x->let (p'', _) = norm (p x) in p'') ms
+                                , msgs)
+                                where (p', msgs) = norm (p "x")
+     norm (Rmv c p ms)        = ( case p' of
+                                   Blk{} -> p'{paMotiv = ms}
+                                   _     -> Rmv c (\x->let (p'', _) = norm (p x) in p'') ms
+                                , msgs)
+                                where (p', msgs) = norm (p "x")
+     norm (Sel c e p ms)      = ( case p' of
+                                   Blk{} -> p'{paMotiv = ms}
+                                   _     -> Sel c e (\x->let (p'', _) = norm (p x) in p'') ms
+                                , msgs)
+                                where (p', msgs) = norm (p "x")
+     norm p                   = (p, [])
+
+
+{- Normalization of expressions -}
+
+   simplify :: Expression -> Expression
+   simplify expr = expr' 
+       where (expr',_,_) = if null (simpProof shw expr) then fatal 101 "last: empty list" else last (simpProof shw expr)
+             shw _ = ""
+   
+   simpProof :: (Expression -> String) -> Expression -> Proof Expression
+   simpProof shw expr    
+    = if expr==res
+      then [(expr,[],"<=>")]
+      else (expr,steps,equ):simpProof shw res
+    where (res,steps,equ) = normStep shw True True True expr
+
+
+   -- | The purpose of "normStep" is to elaborate a single step in a rewrite process,
+   -- in which the expression is normalized by means of rewrite rules.
+   -- This function can be used for simplification, which means that an Expression is standardized
+   -- using associativity and other 'trivial' rules only.
+   -- These 'trivial' rules do not produce a step in the proof.
+   -- Use normstep shw eq True expr to do simplification only.
+   -- Use normstep shw eq False expr to obtain a single proof step or none when no rule is applicable.
+   -- This function returns a resulting expression that is closer to a normal form.
+   -- The normal form is not unique. This function simply uses the first rewrite rule it encounters.
+   normStep :: (Expression -> String) -> Bool -> Bool -> Bool ->
+               Expression -> (Expression,[String],String) -- This might be generalized to "Expression" if it weren't for the fact that flip is embedded in the Relation type.
+   normStep shw   -- a function to print an expression. Might be "showADL"
+            eq    -- If eq==True, only equivalences are used. Otherwise, implications are used as well.
+            dnf   -- If dnf==True, the result is in disjunctive normal form, otherwise in conjunctive normal form
+            simpl -- If True, only simplification rules are used, which is a subset of all rules. Consequently, simplification is implied by normalization.
+            expr = (res,ss,equ)
+    where
+     (res,ss,equ) = nM True expr []
+     nM :: Bool -> Expression -> [Expression] -> (Expression,[String],String)
+-- posCpl indicates whether the expression is positive under a complement. It is False when expr is inside a complemented expression.
+     nM posCpl (EEqu (l,r)) _     | simpl = (t .==. f, steps++steps', fEqu [equ',equ''])
+                                            where (t,steps, equ')  = nM posCpl l []
+                                                  (f,steps',equ'') = nM posCpl r []
+     nM posCpl (EImp (l,r)) _     | simpl = (t .|-. f, steps++steps', fEqu [equ',equ''])
+                                            where (t,steps, equ')  = nM (not posCpl) l []
+                                                  (f,steps',equ'') = nM posCpl r []
+     nM posCpl (ELrs (l,r)) _     | simpl = (t ./. f, steps++steps', fEqu [equ',equ''])     -- l/r  =  l ! -r~  =  -(-l ; r~)
+                                            where (t,steps, equ')  = nM posCpl l []
+                                                  (f,steps',equ'') = nM (not posCpl) r []
+     nM posCpl (ERrs (l,r)) _     | simpl = (t .\. f, steps++steps', fEqu [equ',equ''])
+                                            where (t,steps, equ')  = nM (not posCpl) l []
+                                                  (f,steps',equ'') = nM posCpl r []
+     nM posCpl (EUni (EUni (l,k),r)) rs   = nM posCpl (l .\/. (k .\/. r)) rs  -- standardize, using associativity of .\/.
+     nM posCpl (EUni (l,r)) rs    | simpl = (t .\/. f, steps++steps', fEqu [equ',equ''])
+                                            where (t,steps, equ')  = nM posCpl l []
+                                                  (f,steps',equ'') = nM posCpl r (l:rs)
+     nM posCpl (EIsc (EIsc (l,k),r)) rs   = nM posCpl (l ./\. (k ./\. r)) rs  -- standardize, using associativity of ./\.
+     nM posCpl (EIsc (l,r)) rs    | simpl = (t ./\. f, steps++steps', fEqu [equ',equ''])
+                                            where (t,steps, equ')  = nM posCpl l []
+                                                  (f,steps',equ'') = nM posCpl r (l:rs)
+     nM posCpl (ECps (ECps (l,k),r)) rs   = nM posCpl (l .:. (k .:. r)) rs  -- standardize, using associativity of .:. 
+                                                -- Note: function shiftL and shiftR make use of the fact that this normalizes to (l .:. (k .:. r))
+     nM posCpl (ECps (l,r)) rs    | simpl = (t .:. f, steps++steps', fEqu [equ',equ''])
+                                             where (t,steps, equ')  = nM posCpl l []
+                                                   (f,steps',equ'') = nM posCpl r (l:rs)
+     nM posCpl (ERad (ERad (l,k),r)) rs   = nM posCpl (l .!. (k .!. r)) rs  -- standardize, using associativity of .!.
+     nM posCpl (ERad (l,r)) rs    | simpl = (t .!. f, steps++steps', fEqu [equ',equ''])
+                                            where (t,steps, equ')    = nM posCpl l []
+                                                  (f,steps',equ'')   = nM posCpl r (l:rs)
+     nM posCpl (EPrd (EPrd (l,k),r)) rs   = nM posCpl (l .*. (k .*. r)) rs  -- standardize, using associativity of .*.
+     nM posCpl (EPrd (l,r)) _     | simpl = (t .*. f, steps++steps', fEqu [equ',equ''])
+                                            where (t,steps, equ')  = nM posCpl l []
+                                                  (f,steps',equ'') = nM posCpl r []
+     nM posCpl (EKl0 e)              _    = (EKl0 res', steps, equ')
+                                            where (res',steps,equ') = nM posCpl e []
+     nM posCpl (EKl1 e)              _    = (EKl1 res', steps, equ')
+                                            where (res',steps,equ') = nM posCpl e []
+     nM posCpl (ECpl (ECpl e))         rs = nM (not posCpl) e rs
+     nM posCpl (ECpl e) _         | simpl = (notCpl res',steps,equ')
+                                            where (res',steps,equ') = nM (not posCpl) e []
+     nM posCpl (EBrk e)                _  = nM posCpl e []
+     nM posCpl (EFlp (ECpl e))         rs = nM posCpl (notCpl (flp e)) rs
+     nM _      x _                | simpl = (x,[],"<=>")
+-- up to here, simplification has been treated. The remaining rules can safely assume  simpl==False   --ECpl (EIsc (ECpl (EDcD RELATION r
+     nM _      (EEqu (l,r)) _                            = ((l .|-. r) ./\. (r .|-. l), ["remove ="],"<=>")
+     nM _      (EImp (x,ELrs (z,y))) _                   = (x .:. y .|-. z, ["remove left residual (/)"],"<=>")
+     nM _      (EImp (y,ERrs (x,z))) _                   = (x .:. y .|-. z, ["remove right residual (\\)"],"<=>")
+     nM _      (EImp (l,r)) _                            = (notCpl l .\/. r, ["remove |-"],"<=>")
+     nM _      (ELrs (l,r)) _                            = (l .!. notCpl (flp r), ["remove left residual (/)"],"<=>")
+     nM _      (ERrs (l,r)) _                            = (notCpl (flp l) .!. r, ["remove right residual (\\)"],"<=>")
+     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 (ERad (_,ECpl{}))) _              = (deMorganERad e, ["De Morgan"], "<=>")
+     nM _      e@(ECpl (ERad (ECpl{},_))) _              = (deMorganERad e, ["De Morgan"], "<=>")
+     nM _      e@(ECpl (ECps (ECpl{},ECpl{}))) _         = (deMorganECps e, ["De Morgan"], "<=>")
+     nM posCpl (ECpl e) _                                = (notCpl res',steps,equ')
+                                                           where (res',steps,equ') = nM (not posCpl) e []
+     nM _      (ECps (l,r)) _                | isIdent l = (r, ["I;x = x"], "<=>")
+     nM _      (ECps (l,r)) _                | isIdent r = (l, ["x;I = x"], "<=>")
+     nM True   (ECps (r,ERad (s,q))) _          | not eq = ((r.:.s).!.q, ["Peirce: r;(s!q) |- (r;s)!q"],"==>")
+     nM True   (ECps (ERad (r,s),q)) _          | not eq = (r.!.(s.:.q), ["Peirce: (r!s);q |- r!(s;q)"],"==>")
+     nM True   (ECps (EIsc (r,s),q)) _          | not eq = ((r.:.q)./\.(s.:.q), ["distribute ; over /\\"],"==>")
+     nM True   (ECps (r,EIsc (s,q))) _          | not eq = ((r.:.s)./\.(r.:.q), ["distribute ; over /\\"],"==>")
+     nM _      (ECps (EUni (q,s),r)) _                   = ((q.:.r).\/.(s.:.r), ["distribute ; over \\/"],"<=>")
+     nM _      (ECps (l,EUni (q,s))) _                   = ((l.:.q).\/.(l.:.s), ["distribute ; over \\/"],"<=>")
+     nM _      x@(ECps (l@EFlp{},r)) _ | not eq && flp l==r && isInj l   = (EDcI (source x), ["r~;r |- I (r is univalent)"], "==>")
+     nM _      x@(ECps (l,       r)) _ | not eq && l==flp r && isInj l   = (EDcI (source x), ["r;r~ |- I (r is injective)"], "==>")
+     nM _      x@(ECps (l@EFlp{},r)) _ | flp l==r && isInj l && isTot l  = (EDcI (source x), ["r~;r=I because r is univalent and surjective"], "<=>")
+     nM _      x@(ECps (l,       r)) _ | l==flp r && isInj l && isTot l  = (EDcI (source x), ["r;r~=I because r is injective and total"], "<=>")
+     nM posCpl (ECps (l,r))           rs                     = (t .:. f, steps++steps', fEqu [equ',equ''])
+                                                                 where (t,steps, equ')  = nM posCpl l []
+                                                                       (f,steps',equ'') = nM posCpl r (l:rs)
+     nM _      (ERad (l,r)) _                   | isImin l = (r, ["-I;x = x"], "<=>")
+     nM _      (ERad (l,r)) _                   | isImin r = (l, ["x;-I = x"], "<=>")
+--     nM False  (ERad (ECps (r,s),q)) _            | not eq = (r.:.(s.!.q), ["Peirce: (r;s)!q |- r;(s!q)"],"==>")  -- SJ 20131124 TODO: check this rule. It is wrong!
+--     nM False  (ERad (r,ECps (s,q))) _            | not eq = ((r.!.s).:.q, ["Peirce: (r!s);q |- r!(s;q)"],"==>")  -- SJ 20131124 TODO: check this rule. It is wrong!
+     nM False  (ERad (EUni (r,s),q)) _            | not eq = ((r.!.q).\/.(s.!.q), ["distribute ! over \\/"],"==>")
+     nM False  (ERad (r,EUni (s,q))) _            | not eq = ((r.!.s).\/.(r.!.q), ["distribute ! over \\/"],"==>")
+     nM _      (ERad (EIsc (q,s),r)) _                     = ((q.!.r)./\.(s.!.r), ["distribute ! over /\\"],"<=>")
+     nM _      (ERad (l,EIsc (q,s))) _                     = ((l.!.q)./\.(l.!.s), ["distribute ! over /\\"],"<=>")
+     nM _      x@(ERad(ECpl{},_))    _                     = (deMorganERad x, ["De Morgan"], "<=>")
+     nM _      x@(ERad(_,ECpl{}))    _                     = (deMorganERad x, ["De Morgan"], "<=>")
+     nM posCpl (ERad (l,r))         rs                     = (t .!. f, steps++steps', fEqu [equ',equ''])
+                                                                 where (t,steps, equ')  = nM posCpl l []
+                                                                       (f,steps',equ'') = nM posCpl r (l:rs)
+     nM _      (EPrd (l,EPrd (_,r))) _                     = (l .*. r, ["eliminate middle in cartesian product"], "<=>")
+     nM posCpl (EPrd (l,r)) _                              = (t .*. f, steps++steps', fEqu [equ',equ''])
+                                                                 where (t,steps, equ')  = nM posCpl l []
+                                                                       (f,steps',equ'') = nM posCpl r []
+     nM _      (EIsc (EUni (l,k),r)) _           | dnf     = ((l./\.r) .\/. (k./\.r), ["distribute /\\ over \\/"],"<=>")
+     nM _      (EIsc (l,EUni (k,r))) _           | dnf     = ((l./\.k) .\/. (l./\.r), ["distribute /\\ over \\/"],"<=>")
+     nM _      (EUni (EIsc (l,k),r)) _           | not dnf = ((l.\/.r) ./\. (k.\/.r), ["distribute \\/ over /\\"],"<=>")
+     nM _      (EUni (l,EIsc (k,r))) _           | not dnf = ((l.\/.k) ./\. (l.\/.r), ["distribute \\/ over /\\"],"<=>")
+     nM posCpl x@(EIsc (l,r)) rs
+-- Absorb equals:    r/\r  -->  r
+         | or [length cl>1 |cl<-absorbClasses]
+              = ( case absorbClasses of [] -> fatal 243 "Going into foldr1 with empty absorbClasses"; _ -> foldr1 (./\.) [head cl | cl<-absorbClasses]
+                , [shw e++" /\\ "++shw e++" = "++shw e | cl<-absorbClasses, length cl>1, let e=head cl]
+                , "<=>"
+                )
+-- Inconsistency:    r/\-r   -->  False
+         | not (null incons)
+              = let i = head incons in (notCpl (EDcV (sign i)), [shw (notCpl i)++" /\\ "++shw i++" = V-"], "<=>")
+-- Inconsistency:    x/\\V-  -->  False
+         | (not.null) [t' |t'<-exprIsc2list l++exprIsc2list r, isFalse t']
+              = (notCpl (EDcV (sign x)), ["x/\\V- = V-"], "<=>")
+-- Absorb if r is antisymmetric:    r/\r~ --> I
+         | not eq && or [length cl>1 |cl<-absorbAsy]
+              = ( foldr1 (./\.) [if length cl>1 then EDcI (source e) else e | cl<-absorbAsy, let e=head cl] 
+                , [shw e++" /\\ "++shw (flp e)++" |- I, because"++shw e++" is antisymmetric" | cl<-absorbAsy, let e=head cl]
+                , "==>"
+                )
+-- Absorb if r is antisymmetric and reflexive:    r/\r~ = I
+         | or [length cl>1 |cl<-absorbAsyRfx]
+              = ( foldr1 (./\.) [if length cl>1 then EDcI (source e) else e | cl<-absorbAsyRfx, let e=head cl] 
+                , [shw e++" /\\ "++shw (flp e)++" = I, because"++shw e++" is antisymmetric and reflexive" | cl<-absorbAsyRfx, let e=head cl]
+                , "<=>"
+                )
+-- Absorb:    (x\\/y)/\\y  =  y
+         | isEUni l && not (null absor0)
+              = let t'=head absor0  in (r, ["absorb "++shw l++" because of "++shw t'++", using law  (x\\/y)/\\y = y"], "<=>")
+         | isEUni r && not (null absor0')
+              = let t'=head absor0' in (r, ["absorb "++shw r++" because of "++shw t'++", using law  (x\\/y)/\\x = x"], "<=>")
+-- Absorb:    (x\\/-y)/\\y  =  x/\\y
+         | isEUni l && not (null absor1)
+              = ( case head absor1 of
+                    (_,[]) -> r
+                    (_,ts) -> foldr1 (.\/.) ts ./\. r
+                , ["absorb "++shw t'++", using law (x\\/-y)/\\y  =  x/\\y" | (t',_)<-absor1]
+                , "<=>"
+                )
+         | isEUni r && not (null absor1')
+              = ( case head absor1' of
+                    (_,[]) -> l
+                    (_,ts) -> l ./\. foldr1 (.\/.) ts
+                , ["absorb "++shw t'++", using law x/\\(y\\/-x)  =  x/\\y" | (t',_)<-absor1']
+                , "<=>"
+                )
+         | otherwise = (t ./\. f, steps++steps', fEqu [equ',equ''])
+         where (t,steps, equ')  = nM posCpl l []
+               (f,steps',equ'') = nM posCpl r (l:rs)
+               absorbClasses = eqClass (==) (rs++exprIsc2list l++exprIsc2list r)
+               incons = [conjunct |conjunct<-exprIsc2list r,conjunct==notCpl l]
+               absor0  = [disjunct | disjunct<-exprUni2list l, f'<-rs++exprIsc2list r, disjunct==f']
+               absor0' = [disjunct | disjunct<-exprUni2list r, f'<-rs++exprIsc2list l, disjunct==f']
+               absor1  = [(disjunct, exprUni2list l>-[disjunct]) | disjunct<-exprUni2list l, ECpl f'<-rs++exprIsc2list r, disjunct==f']++
+                         [(disjunct, exprUni2list l>-[disjunct]) | disjunct@(ECpl t')<-exprUni2list l, f'<-rs++exprIsc2list r, t'==f']
+               absor1' = [(disjunct, exprUni2list r>-[disjunct]) | disjunct<-exprUni2list r, ECpl f'<-rs++exprIsc2list l, disjunct==f']++
+                         [(disjunct, exprUni2list r>-[disjunct]) | disjunct@(ECpl t')<-exprUni2list r, f'<-rs++exprIsc2list l, t'==f']
+               absorbAsy = eqClass same eList where e `same` e' = isAsy e && isAsy e' && e == flp e'
+               absorbAsyRfx = eqClass same eList where e `same` e' = isRfx e && isAsy e && isRfx e' && isAsy e' && e == flp e'
+               eList  = rs++exprIsc2list l++exprIsc2list r
+     nM posCpl x@(EUni (l,r)) rs
+-- Absorb equals:    r\/r  -->  r
+         | or [length cl>1 |cl<-absorbClasses]   -- yields False if absorbClasses is empty
+              = ( foldr1 (.\/.) [head cl | cl<-absorbClasses]  -- cl cannot be empty, because it is made by eqClass
+                , [shw e++" \\/ "++shw e++" = "++shw e | cl<-absorbClasses, length cl>1, let e=head cl]
+                , "<=>"
+                )
+-- Tautologies:
+         | (not.null) tauts               = (EDcV (sign x), ["let e = "++ shw (head tauts)++". Since -e\\/e = V we get"], "<=>")   -- r\/-r  -->  V
+         | isTrue l                       = (EDcV (sign x), ["V\\/x = V"], "<=>")                                                  -- r\/V   -->  V
+         | isTrue r                       = (EDcV (sign x), ["x\\/V = V"], "<=>")
+-- Absorb -V:    r\/-V  --> r
+         | isFalse l                      = (r, ["-V\\/x = x"], "<=>")
+         | isFalse r                      = (l, ["x\\/-V = x"], "<=>")
+-- Absorb:    (x/\\y)\\/y  =  y
+         | isEIsc l && not (null absor0)  = let t'=head absor0  in (r, ["absorb "++shw l++" because of "++shw t'++", using law  (x/\\y)\\/y = y"], "<=>")
+         | isEIsc r && not (null absor0') = let t'=head absor0' in (r, ["absorb "++shw r++" because of "++shw t'++", using law  (x/\\y)\\/x = x"], "<=>")
+-- Absorb:    (x/\\-y)\\/y  =  x\\/y
+         | isEIsc l && not (null absor1)
+              = ( case head absor1 of
+                    (_,[]) -> r
+                    (_,ts) -> foldr1 (./\.) ts .\/. r
+                , ["absorb "++shw t'++", using law (x/\\-y)\\/y  =  x\\/y" | (t',_)<-absor1]
+                , "<=>"
+                )
+         | isEIsc r && not (null absor1')
+              = ( case head absor1' of
+                    (_,[]) -> l
+                    (_,ts) -> l .\/. foldr1 (./\.) ts
+                , ["absorb "++shw t'++", using law x\\/(y/\\-x)  =  x\\/y" | (t',_)<-absor1' ]
+                , "<=>"
+                )
+ -- Jumping Beetles!   The following alternative is incorrect. It should yield t .\/. f (instead of now: t ./\. f)
+ -- However, it covers a more serious mistake in the generation of ECA-rules,
+ -- which causes the Sentinel to flip. So we keep it covered until that mistake is fixed.
+ -- SJC 24 nov 2013: I care not! I've repaired this. Please fix whatever needs to be fixed instead of covering up the occurence!
+         | otherwise = (t .\/. f, steps++steps', fEqu [equ',equ''])
+         where (t,steps, equ')  = nM posCpl l []
+               (f,steps',equ'') = nM posCpl r (l:rs)
+            -- absorption can take place if two terms are equal. So let us make a list of equal terms: absorbClasses (for substituting r\/r by r)
+               absorbClasses = eqClass (==) (rs++exprUni2list l++exprUni2list r)
+            -- tautologies occur if -r\/r, so we are looking for pairs, (x,l) such that x== -l
+               tauts = [t' |disjunct<-exprUni2list r,disjunct==notCpl l, ECpl t'<-[disjunct,l]]
+               absor0  = [t' | t'<-exprIsc2list l, f'<-rs++exprUni2list r, t'==f']
+               absor0' = [t' | t'<-exprIsc2list r, f'<-rs++exprUni2list l, t'==f']
+               absor1  = [(t', exprIsc2list l>-[t']) | t'<-exprIsc2list l, ECpl f'<-rs++exprUni2list r, t'==f']++[(e, exprIsc2list l>-[e]) | e@(ECpl t')<-exprIsc2list l, f'<-rs++exprUni2list r, t'==f']
+               absor1' = [(t', exprIsc2list r>-[t']) | t'<-exprIsc2list r, ECpl f'<-rs++exprUni2list l, t'==f']++[(e, exprIsc2list r>-[e]) | e@(ECpl t')<-exprIsc2list r, f'<-rs++exprUni2list l, t'==f']
+     nM _ (EFlp e) _ | isSym e =  (e,[shw e++" is symmetric"],"<=>")
+     nM _ x _               = (x,[],"<=>")
+
+   exprIsc2list, exprUni2list, exprCps2list, exprRad2list :: Expression -> [Expression]
+   exprIsc2list (EIsc (l,r)) = exprIsc2list l++exprIsc2list r
+   exprIsc2list r            = [r]
+   exprUni2list (EUni (l,r)) = exprUni2list l++exprUni2list r
+   exprUni2list r            = [r]
+   exprCps2list (ECps (l,r)) = exprCps2list l++exprCps2list r
+   exprCps2list r            = [r]
+   exprRad2list (ERad (l,r)) = exprRad2list l++exprRad2list r
+   exprRad2list r            = [r]
+
+
+   fEqu :: [String] -> String
+   fEqu ss = if and [s=="<=>" | s<-ss] then "<=>" else "==>"
+
+   nfProof :: (Expression -> String) -> Expression -> Proof Expression
+   nfProof shw = nfPr shw True True -- The first boolean True means that clauses are derived using <=> derivations. The second True means that a disjunctive normal form is produced.
+   nfPr :: (Expression -> String) -> Bool -> Bool -> Expression -> [(Expression, [String], String)]
+   nfPr shw eq dnf expr
+    = {-if showADL expr=="r \\/ s"
+      then fatal 360 ("Diagnose expr: "++showADL expr++"\n"++
+                      "eq:            "++show eq++"\n"++
+                      "dnf:           "++show eq++"\n"++
+                      "res:           "++showADL res++"\n"++
+                      "expr==res:     "++show (expr==res)
+                     ) else-}
+      if expr==res
+      then [(expr,[],"<=>")]
+      else (expr,steps,equ):nfPr shw eq dnf (simplify res)
+    where (res,steps,equ) = normStep shw eq dnf False expr
+
+   cfProof :: (Expression -> String) -> Expression -> Proof Expression
+   cfProof shw expr
+    = [line | step, line<-init pr]++
+      [line | step', line<-init pr']++
+      [last ([(expr,[],"<=>")]++
+             [line | step, line<-pr]++
+             [line | step', line<-pr']
+            )]
+      where pr           = nfPr shw True False (simplify expr)
+            (expr',_,_)  = if null pr then fatal 328 "last: empty list" else last pr
+            step         = simplify expr/=expr' -- obsolete?    || and [null s | (_,ss,_)<-pr, s<-ss]
+            pr'          = nfPr shw True False (simplify expr')
+            step'        = simplify expr'/=simplify expr'' -- obsolete?    || and [null s | (_,ss,_)<-pr', s<-ss]
+            (expr'',_,_) = if null pr' then fatal 337 "last: empty list" else last pr'
+
+   conjNF :: Expression -> Expression
+   conjNF expr = e where (e,_,_) = if null (cfProof (\_->"") expr) then fatal 340 "last: empty list" else last (cfProof (\_->"") expr)
+
+   disjNF :: Expression -> Expression
+   disjNF expr = e where (e,_,_) = if null (dfProof (\_->"") expr) then fatal 343 "last: empty list" else last (dfProof (\_->"") expr)
+
+   dfProof :: (Expression -> String) -> Expression -> Proof Expression
+   dfProof shw expr
+    = [line | step, line<-init pr]++
+      [line | step', line<-init pr']++
+      [last ([(expr,[],"<=>")]++
+             [line | step, line<-pr]++
+             [line | step', line<-pr']
+            )]
+      where pr           = nfPr shw True True expr
+            (expr',_,_)  = if null pr then fatal 356 "last: empty list" else last pr
+            step         = simplify expr/=simplify expr'
+            pr'          = nfPr shw True True expr'
+            step'        = simplify expr'/=simplify expr''
+            (expr'',_,_) = if null pr' then fatal 365 "last: empty list" else last pr'
+
+   isEUni :: Expression -> Bool
+   isEUni EUni{}  = True
+   isEUni _       = False
+
+   isEIsc :: Expression -> Bool
+   isEIsc EIsc{}  = True
+   isEIsc _       = False
+
+ src/lib/DatabaseDesign/Ampersand/Input.hs view
@@ -0,0 +1,6 @@+{-# OPTIONS_GHC -Wall #-}  
+module DatabaseDesign.Ampersand.Input (
+   module X
+)where
+import DatabaseDesign.Ampersand.Input.ADL1.CtxError as X (CtxError)
+import DatabaseDesign.Ampersand.Input.Parsing as X (parseADL1pExpr)
+ src/lib/DatabaseDesign/Ampersand/Input/ADL1/CtxError.hs view
@@ -0,0 +1,178 @@+{-# OPTIONS_GHC -Wall -XFlexibleInstances #-}
+module DatabaseDesign.Ampersand.Input.ADL1.CtxError
+  ( CtxError(PE)
+  , showErr
+  , cannotDisamb, cannotDisambRel
+  , mustBeOrdered, mustBeOrderedLst, mustBeOrderedConcLst
+  , mustBeBound
+  , GetOneGuarded(..), uniqueNames
+  , Guarded(..)
+  , (<?>)
+  )
+-- SJC: I consider it ill practice to export CTXE
+-- Reason: CtxError should obtain all error messages
+-- By not exporting anything that takes a string, we prevent other modules from containing error message
+-- If you build a function that must generate an error, put it in CtxError and call it instead
+-- see `getOneExactly' / `GetOneGuarded' as a nice example
+-- Although I also consider it ill practice to export PE, I did this as a quick fix for the parse errors
+where
+import Control.Applicative
+import DatabaseDesign.Ampersand.ADL1 (Pos(..),source,target,sign,Expression(EDcV,ECpl),A_Concept,SubInterface)
+import DatabaseDesign.Ampersand.Fspec.ShowADL
+import DatabaseDesign.Ampersand.Basics
+-- import Data.Traversable
+import Data.List  (intercalate, partition)
+import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner (Token)
+import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing (Message)
+import DatabaseDesign.Ampersand.Core.ParseTree (TermPrim(..),P_ViewD(..),P_SubIfc,Traced(..), Origin(..), SrcOrTgt(..),FilePos(..))
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree (Declaration,Association)
+
+fatal,_notUsed :: Int -> String -> a
+fatal = fatalMsg "Input.ADL1.CtxError"
+_notUsed = fatal
+
+infixl 4 <?>
+(<?>) :: (t -> Guarded a) -> Guarded t -> Guarded a  -- This is roughly the monadic definition for >>=, but it does not satisfy the corresponding rules so it cannot be a monad
+(<?>) _ (Errors  a) = Errors a -- note the type change
+(<?>) f (Checked a) = f a
+
+data CtxError = CTXE Origin String -- SJC: I consider it ill practice to export CTXE, see remark at top
+              | PE (Message Token)
+              deriving Show
+
+errors :: Guarded t -> [CtxError]
+errors (Checked _) = []
+errors (Errors lst) = lst
+
+class GetOneGuarded a where
+  getOneExactly :: (Traced a1, ShowADL a1) => a1 -> [a] -> Guarded a
+  getOneExactly _ [a] = Checked a
+  getOneExactly o l@[] = hasNone l o
+  getOneExactly o lst = Errors [CTXE o'$ "Found too many:\n  "++s | CTXE o' s <- errors (hasNone lst o)]
+  hasNone :: (Traced a1, ShowADL a1) => [a] -- this argument should be ignored! It is only here to help indicate a type (you may put [])
+                                     -> a1  -- the object where the problem is arising
+                                     -> Guarded a
+  hasNone _ o = getOneExactly o []
+
+instance GetOneGuarded (P_SubIfc a) where
+  hasNone _ o = Errors [CTXE (origin o)$ "Required: one subinterface in "++showADL o]
+
+instance GetOneGuarded (SubInterface) where
+  hasNone _ o = Errors [CTXE (origin o)$ "Required: one subinterface in "++showADL o]
+
+instance GetOneGuarded Declaration where
+  getOneExactly _ [d] = Checked d
+  getOneExactly o []  = Errors [CTXE (origin o)$ "No declaration for "++showADL o]
+  getOneExactly o lst = Errors [CTXE (origin o)$ "Too many declarations match "++showADL o++".\n  Be more specific. These are the matching declarations:"++concat ["\n  - "++showADL l++" at "++(showFullOrig$origin l) | l<-lst]]
+
+cannotDisambRel :: (ShowADL a2, Association a2) => (TermPrim) -> [a2] -> Guarded a
+cannotDisambRel o [] = Errors [CTXE (origin o)$ "No declarations match the relation: "++showADL o]
+cannotDisambRel o@Prel{} lst = Errors [CTXE (origin o)$ "Cannot disambiguate the relation: "++showADL o++"\n  Please add a signature (e.g. [A*B]) to the relation.\n  Relations you may have intended:"++concat ["\n  "++showADL l++"["++showADL (source l)++"*"++showADL (target l)++"]"|l<-lst]]
+cannotDisambRel o lst = Errors [CTXE (origin o)$ "Cannot disambiguate: "++showADL o++"\n  Please add a signature.\n  You may have intended one of these:"++concat ["\n  "++showADL l|l<-lst]]
+cannotDisamb :: (Traced a1, ShowADL a1) => a1 -> Guarded a
+cannotDisamb o = Errors [CTXE (origin o)$ "Cannot disambiguate: "++showADL o++"\n  Please add a signature to it"]
+
+uniqueNames :: (Identified a, Traced a) =>
+                     [a] -> Guarded ()
+uniqueNames a = case findDuplicates (map name a) of
+                  [] -> pure ()
+                  [r] -> Errors [CTXE (origin (head a))$ "Names / labels must be unique. "++show r++", however, is not."]
+                  r -> Errors [CTXE (origin (head a))$ "Names / labels must be unique. The following are not: "++concat ["\n  - "++l'|l'<-r]]
+findDuplicates :: Eq a => [a] -> [a]
+findDuplicates [] = []
+findDuplicates (a:as)
+ = case (partition (== a) as) of
+    ([],r) -> findDuplicates r
+    (_,r) -> a:findDuplicates r
+
+class ErrorConcept a where
+  showEC :: a -> String
+  showMini :: a -> String
+
+instance ErrorConcept (P_ViewD a) where
+  showEC x = showADL (vd_cpt x) ++" given in VIEW "++vd_lbl x
+  showMini x = showADL (vd_cpt x)
+
+instance (ShowADL a2) => ErrorConcept (SrcOrTgt, A_Concept, a2) where
+  showEC (p1,c1,e1) = showADL c1++" ("++show p1++" of "++showADL e1++")"
+  showMini (_,c1,_) = showADL c1
+
+instance (ShowADL a2, Association a2) => ErrorConcept (SrcOrTgt, a2) where
+  showEC (p1,e1)
+   = case p1 of
+      Src -> showEC (p1,source e1,e1)
+      Tgt -> showEC (p1,target e1,e1)
+  showMini (p1,e1)
+   = case p1 of
+      Src -> showMini (p1,source e1,e1)
+      Tgt -> showMini (p1,target e1,e1)
+
+mustBeOrdered :: (Traced a1, ErrorConcept a2, ErrorConcept a3) => a1 -> a2 -> a3 -> Guarded a
+mustBeOrdered o a b
+ = Errors [CTXE (origin o)$ "Type error, cannot match:\n  the concept "++showEC a
+                                          ++"\n  and concept "++showEC b
+                   ++"\n  if you think there is no type error, add an order between concepts "++showMini a++" and "++showMini b++"."]
+
+mustBeOrderedLst :: (Traced o, ShowADL o, ShowADL a) => o -> [(A_Concept, SrcOrTgt, a)] -> Guarded b
+mustBeOrderedLst o lst
+ = Errors [CTXE (origin o)$ "Type error in "++showADL o++"\n  Cannot match:"++ concat
+             [ "\n  - concept "++showADL c++", "++show st++" of "++showADL a
+             | (c,st,a) <- lst ] ++
+             "\n  if you think there is no type error, add an order between the mismatched concepts."
+          ]
+ 
+
+
+mustBeOrderedConcLst :: Origin -> (SrcOrTgt, Expression) -> (SrcOrTgt, Expression) -> [[A_Concept]] -> Guarded a
+mustBeOrderedConcLst o (p1,e1) (p2,e2) cs
+ = Errors [CTXE o$ "Ambiguous type when matching: "++show p1++" of "++showADL e1++"\n"
+                                          ++" and "++show p2++" of "++showADL e2++".\n"
+                   ++"  The type can be "++intercalate " or " (map (showADL . Slash) cs)
+                   ++"\n  None of these concepts is known to be the smallest, you may want to add an order between them."]
+
+newtype Slash a = Slash [a]
+instance ShowADL a => ShowADL (Slash a) where
+  showADL (Slash x) = intercalate "/" (map showADL x)
+  
+
+mustBeBound :: Origin -> [(SrcOrTgt, Expression)] -> Guarded a
+mustBeBound o [(p,e)]
+ = Errors [CTXE o$ "An ambiguity arises in type checking. Be more specific by binding the "++show p++" of the expression "++showADL e++".\n"++
+                   "  You could add more types inside the expression, or just write "++writeBind e++"."]
+mustBeBound o lst
+ = Errors [CTXE o$ "An ambiguity arises in type checking. Be more specific in the expressions "++intercalate " and " (map (showADL . snd) lst) ++".\n"++
+                   "  You could add more types inside the expression, or write:"++
+                   concat ["\n  "++writeBind e| (_,e)<-lst]]
+
+writeBind :: Expression -> String
+writeBind (ECpl e)
+ = "("++showADL (EDcV (sign e))++"["++showADL (source e)++"*"++showADL (target e)++"]"++" - "++showADL e++")"
+writeBind e
+ = "("++showADL e++") /\\ "++showADL (EDcV (sign e))++"["++showADL (source e)++"*"++showADL (target e)++"]"
+
+data Guarded a = Errors [CtxError] | Checked a deriving Show
+
+instance Functor Guarded where
+ fmap _ (Errors a) = (Errors a)
+ fmap f (Checked a) = Checked (f a)
+ 
+instance Applicative Guarded where
+ pure = Checked
+ (<*>) (Checked f) (Checked a) = Checked (f a)
+ (<*>) (Errors  a) (Checked _) = Errors a 
+ (<*>) (Checked _) (Errors  b) = Errors b
+ (<*>) (Errors  a) (Errors  b) = Errors (a ++ b) -- this line makes Guarded not a monad
+ -- Guarded is NOT a monad!
+ -- Reason: (<*>) has to be equal to `ap' if it is, and this definition is different
+ -- Use <?> if you wish to use the monad-like thing
+
+showErr :: CtxError -> String
+showErr (CTXE o s)
+ = s ++ "\n  " ++ showFullOrig o
+showErr (PE s)
+ = show s
+
+showFullOrig :: Origin -> String
+showFullOrig (FileLoc (FilePos (filename,DatabaseDesign.Ampersand.ADL1.Pos l c,t)))
+              = "Error at symbol "++ t ++ " in file " ++ filename++" at line " ++ show l++" : "++show c
+showFullOrig x = show x
+ src/lib/DatabaseDesign/Ampersand/Input/ADL1/FilePos.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Input.ADL1.FilePos
+       ( FilePos(..), Origin(..), Pos(Pos) , Traced(..),posIn)
+where
+   import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner (Pos(Pos))
+--   import DatabaseDesign.Ampersand.Basics      (fatalMsg)
+
+--   fatal :: Int -> String -> a
+--   fatal = fatalMsg "Input.ADL1.FilePos"
+
+   --Traced a have an origin, which may be unknown.
+   data FilePos = FilePos ( String, Pos, String) deriving (Eq, Ord)
+   data Origin = SomewhereNear String | OriginUnknown | Origin String | FileLoc FilePos | DBLoc String deriving (Eq, Ord)
+--line column pos
+
+   posIn :: Traced a => Origin -> a -> Origin -> Bool
+   posIn (FileLoc (FilePos (f , Pos bl bc, _)))
+         x
+         (FileLoc (FilePos (f', Pos el ec, _)))
+         | f/=f' = False
+         | bl==el = bc < colnr x && colnr x < ec
+         | otherwise = bl < linenr x && linenr x < el
+   posIn _ _ _ = False
+ 
+   instance Show FilePos where
+     show (FilePos (fn,Pos l c,_))
+       = "line " ++ show l++":"++show c
+            ++ ", file " ++ show fn
+
+   instance Show Origin where
+     show (FileLoc pos) = show pos
+     show (DBLoc str)   = "Database location: "++str
+     show (Origin str)  = str
+     show OriginUnknown = "Unknown origin"
+     show (SomewhereNear str) = "Somewhere near: "++str
+   class Traced a where
+    origin :: a -> Origin
+    filenm :: a -> String
+    linenr :: a -> Int
+    colnr :: a -> Int
+    filenm x = case origin x of 
+                     FileLoc (FilePos (nm, _, _)) -> nm
+                     _ -> ""
+    linenr x = case origin x of 
+                     FileLoc (FilePos (_,Pos l _,_)) -> l
+                     _ -> 0
+    colnr x  = case origin x of 
+                     FileLoc (FilePos (_,Pos _ c,_)) -> c
+                     _ -> 0
+
+   instance Traced Origin where
+    origin = id
+
+
+ src/lib/DatabaseDesign/Ampersand/Input/ADL1/Parser.hs view
@@ -0,0 +1,784 @@+{-# OPTIONS_GHC -Wall -fno-enable-rewrite-rules #-}+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}+module DatabaseDesign.Ampersand.Input.ADL1.Parser +   (pContext, pPopulations,pTerm, keywordstxt, keywordsops, specialchars, opchars) where+   import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner+            ( Token(..),TokenType(..),noPos+            , pKey,pConid,pString,pSpec,pAtom,pExpl,pVarid,pComma,pInteger)+   import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing+            (Parser+            , (<$>) , (<$), (<*>), (<*), (*>), (<|>), (<??>)+            ,pList,pListSep,pList1,pList1Sep,pSym+            ,pSucceed+            ,opt, Sequence,Alternative, IsParser+            )+   import DatabaseDesign.Ampersand.Basics  (fatalMsg,Collection(..))+   import DatabaseDesign.Ampersand.Core.ParseTree    +   import Data.List (nub,sort)+   import Data.Maybe+   +   fatal :: Int -> String -> a+   fatal = fatalMsg "Input.ADL1.Parser"++--  The Ampersand scanner takes the file name (String) for documentation and error messaging.+--   scanner :: String -> String -> [Token]+--   scanner fn str = scan keywordstxt keywordsops specialchars opchars fn initPos str++   keywordstxt :: [String]+   keywordstxt       = [ "INCLUDE"+                       , "CONTEXT", "ENDCONTEXT", "EXTENDS", "THEMES"+                       , "META"+                       , "PATTERN", "ENDPATTERN"+                       , "PROCESS", "ENDPROCESS"+                       , "INTERFACE", "FOR", "BOX", "INITIAL", "SQLPLUG", "PHPPLUG", "TYPE"+                       , "POPULATION", "CONTAINS"+                       , "UNI", "INJ", "SUR", "TOT", "SYM", "ASY", "TRN", "RFX", "IRF", "PROP", "ALWAYS"+                       , "RULE", "MESSAGE", "VIOLATION", "SRC", "TGT", "TEST"+                       , "RELATION", "MEANING", "DEFINE", "CONCEPT", "IDENT"+                       , "VIEW", "TXT", "PRIMHTML"+                       , "KEY" -- HJO, 20130605: Obsolete. Only usefull as long as the old prototype generator is still in use.+                       , "IMPORT", "SPEC", "ISA", "IS", "I", "V"+                       , "CLASSIFY"+                       , "PRAGMA", "EXPLAIN", "PURPOSE", "IN", "REF", "ENGLISH", "DUTCH"+                       , "REST", "HTML", "LATEX", "MARKDOWN"+                       , "ONE"+                       , "BYPLUG"+                       , "ROLE", "EDITS", "MAINTAINS"+                       ]+   keywordsops :: [String]+   keywordsops       = [ "|-", "-", "->", "<-", ">", "=", "~", "+", ";", "!", "*", "::", ":", "\\/", "/\\", "\\", "/", "<>"+                       , "..", "." , "0", "1"]+   specialchars :: String+   specialchars      = "()[],{}"+   opchars :: String+   opchars           = nub (sort (concat keywordsops))++   --to parse files containing only populations+   pPopulations :: Parser Token [P_Population]+   pPopulations = pList1 pPopulation++   pContext :: Parser Token (P_Context, [String]) -- the result is the parsed context and a list of include filenames+   pContext  = rebuild <$> pKey_pos "CONTEXT" <*> pConid+                            <*> pList pIncludeStatement +                            <*> optional pLanguageRef +                            <*> optional pTextMarkup +                            <*> pList pContextElement <* pKey "ENDCONTEXT"+     where+       rebuild :: Origin -> String -> [String] -> Maybe Lang -> Maybe PandocFormat -> [ContextElement] -> (P_Context, [String])+       rebuild pos' nm includeFileNames 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 declarations defined in this context, outside the scope of patterns+               , ctx_cs     = [c | CCon c<-ces]       -- The concept definitions defined in this context, outside the scope of patterns+               , ctx_gs     = [g | CGen g<-ces]       -- The gen definitions defined in this context, outside the scope of patterns+               , ctx_ks     = [k | CIndx k<-ces]      -- The identity definitions defined in this context, outside the scope of patterns+               , ctx_vs     = [v | CView v<-ces]      -- The view definitions defined in this context, outside the scope of patterns+               , ctx_ifcs   = [s | Cifc s<-ces]       -- The interfaces defined in this context, outside the scope of patterns -- fatal 78 ("Diagnostic: "++concat ["\n\n   "++show ifc | Cifc ifc<-ces])+               , ctx_sql    = [p | CSqlPlug p<-ces]   -- user defined sqlplugs, taken from the Ampersand scriptplug<-ces]  +               , ctx_php    = [p | CPhpPlug p<-ces]   -- user defined phpplugs, taken from the Ampersand script+               , ctx_ps     = [e | CPrp e<-ces]       -- The purposes defined in this context, outside the scope of patterns+               , ctx_pops   = [p | CPop p<-ces]       -- The populations defined in this contextplug<-ces]  +               , ctx_metas  = [m | CMeta m <-ces]+               }+          , includeFileNames)++       pContextElement :: Parser Token ContextElement+       pContextElement = CMeta    <$> pMeta         <|>+                         CPat     <$> pPatternDef   <|>+                         CPrc     <$> pProcessDef   <|>+                         CRul     <$> pRuleDef      <|>+                         CCfy     <$> pClassify     <|>+                         CRel     <$> pRelationDef  <|>+                         CCon     <$> pConceptDef   <|>+                         CGen     <$> pGenDef       <|>+                         CIndx    <$> pIndex        <|>+                         CView    <$> pViewDef      <|>+                         Cifc     <$> pInterface    <|>+                         CSqlPlug <$> pSqlplug      <|>+                         CPhpPlug <$> pPhpplug      <|>+                         CPrp     <$> pPurpose      <|>+                         CPop     <$> pPopulation   <|>+                         CThm     <$> pPrintThemes+++   data ContextElement = CMeta Meta+                       | CPat P_Pattern+                       | CPrc P_Process+                       | CRul (P_Rule TermPrim)+                       | CCfy P_Gen+                       | CRel P_Declaration+                       | CCon 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.++   pIncludeStatement :: Parser Token String+   pIncludeStatement = pKey "INCLUDE" *> pString++   pLanguageRef :: Parser Token Lang+   pLanguageRef = pKey "IN" *> +                  (( Dutch   <$ pKey "DUTCH"  ) <|>+                   ( English <$ pKey "ENGLISH")+                  )+   pTextMarkup :: Parser Token PandocFormat+   pTextMarkup = ( ReST     <$ pKey "REST"     ) <|>+                 ( HTML     <$ pKey "HTML"     ) <|>+                 ( LaTeX    <$ pKey "LATEX"    ) <|>+                 ( Markdown <$ pKey "MARKDOWN" )++   pMeta :: Parser Token Meta+   pMeta = Meta <$> pKey_pos "META" <*> pMetaObj <*> pString <*> pString+    where pMetaObj = pSucceed ContextMeta -- for the context meta we don't need a keyword+    +   pPatternDef :: Parser Token P_Pattern+   pPatternDef = rebuild <$> pKey_pos "PATTERN" <*> pConceptName   -- The name spaces of patterns, processes and concepts are shared.+                         <*> pList pPatElem+                         <*> pKey_pos "ENDPATTERN"+     where+       rebuild :: Origin -> String -> [PatElem] -> Origin -> P_Pattern+       rebuild pos' nm pes end+        = P_Pat { pt_nm  = nm+                , pt_pos = pos'+                , pt_end = end+                , pt_rls = [r | Pr r<-pes]+                , pt_gns = [g | Pg g<-pes]+                , pt_dcs = [d | Pd d<-pes]+                , pt_rus = [r | Pm r<-pes]+                , pt_res = [r | Pl r<-pes]+                , pt_cds = [c | Pc c<-pes]+                , pt_ids = [k | Pk k<-pes]+                , pt_vds = [v | Pv v<-pes]+                , pt_xps = [e | Pe e<-pes]+                , pt_pop = [p | Pp p<-pes]+                } +       pPatElem :: Parser Token PatElem+       pPatElem = Pr <$> pRuleDef      <|>+                  Py <$> pClassify     <|>+                  Pd <$> pRelationDef  <|>+                  Pm <$> pRoleRule     <|>+                  Pl <$> pRoleRelation <|>+                  Pc <$> pConceptDef   <|>+                  Pg <$> pGenDef       <|>+                  Pk <$> pIndex        <|>+                  Pv <$> pViewDef      <|>+                  Pe <$> pPurpose      <|>+                  Pp <$> pPopulation++   data PatElem = Pr (P_Rule TermPrim)+                | Py P_Gen+                | Pd P_Declaration +                | Pm RoleRule+                | Pl P_RoleRelation+                | Pc ConceptDef+                | Pg P_Gen+                | Pk P_IdentDef+                | Pv P_ViewDef+                | Pe PPurpose+                | Pp P_Population+                              +   pProcessDef :: Parser Token P_Process+   pProcessDef = rebuild <$> pKey_pos "PROCESS" <*> pConceptName   -- The name spaces of patterns, processes and concepts are shared.+                         <*> pList pProcElem+                         <*> pKey_pos "ENDPROCESS"+      where+       rebuild :: Origin -> String -> [ProcElem] -> Origin -> P_Process+       rebuild pos' nm pes end+         = P_Prc { procNm    = nm+                 , procPos   = pos'+                 , procEnd   = end+                 , procRules = [rr | PrR rr<-pes]+                 , procGens  = [g  | PrG g <-pes]+                 , procDcls  = [d  | PrD d <-pes]+                 , procRRuls = [rr | PrM rr<-pes]+                 , procRRels = [rr | PrL rr<-pes]+                 , procCds   = [cd | PrC cd<-pes]+                 , procIds   = [ix | PrI ix<-pes]+                 , procVds   = [vd | PrV vd<-pes]+                 , procXps   = [e  | PrE e <-pes]+                 , procPop   = [p  | PrP p <-pes]+                 }+       pProcElem :: Parser Token ProcElem+       pProcElem = PrR <$> pRuleDef      <|>+                   PrY <$> pClassify     <|>+                   PrD <$> pRelationDef  <|>+                   PrM <$> pRoleRule     <|>+                   PrL <$> pRoleRelation <|>+                   PrC <$> pConceptDef   <|>+                   PrG <$> pGenDef       <|>+                   PrI <$> pIndex        <|>+                   PrV <$> pViewDef      <|>+                   PrE <$> pPurpose      <|>+                   PrP <$> pPopulation++   data ProcElem = PrR (P_Rule TermPrim)+                 | PrY P_Gen+                 | PrD P_Declaration+                 | PrM RoleRule+                 | PrL P_RoleRelation+                 | PrC ConceptDef+                 | PrG P_Gen+                 | PrI P_IdentDef+                 | PrV P_ViewDef+                 | PrE PPurpose+                 | PrP P_Population++   pClassify :: Parser Token P_Gen+   pClassify = rebuild <$> pKey_pos "CLASSIFY"+                       <*> pConceptRef+                       <*  pKey "IS"+                       <*> pCterm+                  where+                    rebuild po lhs rhs+                      = P_Cy { gen_spc  = lhs             --  Left hand side concept expression +                             , gen_rhs  = rhs             --  Right hand side concept expression+                             , gen_fp   = po+                             }+                    pCterm  = f <$> pList1Sep (pKey "/\\") pCterm1+                    pCterm1 = g <$> pConceptRef                        <|>+                              h <$> (pSpec '(' *> pCterm <* pSpec ')')  -- brackets are allowed for educational reasons.+                    f ccs = concat ccs+                    g c = [c]+                    h cs = cs++   +   pRuleDef :: Parser Token (P_Rule TermPrim)+   pRuleDef =  rebuild <$> pKey_pos "RULE"+                       <*> optional (pADLid <* pKey ":" )+                       <*> pRule+                       <*> pList pMeaning                 +                       <*> pList pMessage+                       <*> optional pViolation+                  where+                    rebuild po mn rexp mean msg mViolation+                      = P_Ru { rr_nm   = fromMaybe (rulid po) mn+                             , rr_exp  = rexp+                             , rr_fps  = po+                             , rr_mean = mean+                             , rr_msg  = msg+                             , rr_viol = mViolation+                             }+                    rulid (FileLoc(FilePos (_,Pos l _,_))) = "rule@line"++show l+                    rulid _ = fatal 226 "pRuleDef is expecting a file location."+                    pViolation :: Parser Token (PairView (Term TermPrim))+                    pViolation = id <$ pKey "VIOLATION" <*> pPairView+               +                    pPairView :: Parser Token (PairView (Term TermPrim))+                    pPairView = PairView <$ pSpec '(' <*> pList1Sep (pSpec ',') pPairViewSegment <* pSpec ')'+               +                    pPairViewSegment :: Parser Token (PairViewSegment (Term TermPrim))+                    pPairViewSegment = PairViewExp <$> pSrcOrTgt <*>  pTerm+                                   <|> PairViewText <$ pKey "TXT" <*> pString+   +   pSrcOrTgt :: Parser Token SrcOrTgt                    +   pSrcOrTgt = Src <$ pKey "SRC" <|> Tgt <$ pKey "TGT"+++   pRelationDef :: Parser Token P_Declaration+   pRelationDef      = ( rebuild <$> pVarid  <*> pKey_pos "::"  <*> pConceptRef  <*> pFun  <*> pConceptRef+                         <|> rbd <$> pKey_pos "RELATION" <*> pVarid  <*> pSign+                       )+                         <*> ((True <$ pKey "BYPLUG") `opt` False)+                         <*> (pProps `opt` [])+                         <*> ((True <$ pKey "BYPLUG") `opt` False)+                         <*> (pPragma `opt` [])+                         <*> pList pMeaning+                         <*> ((\st d -> Just $ RelConceptDef st d) <$ pKey "DEFINE" <*> pSrcOrTgt <*> pString `opt` Nothing)+                         <*> ((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 conceptDef content+                               = rbd pos' nm (P_Sign src trg,pos') bp1 props' --bp2 pragma meanings conceptDef content+                                 where props'= nub (props `uni` fun')+                             rbd pos' nm (sgn,_) bp1 props bp2 pragma meanings conceptDef 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_conceptDef = conceptDef+                                       , dec_popu = content+                                       , dec_fpos = pos'+                                       , dec_plug = bp1 || bp2+                                       }+                                 where pr = pragma++["","",""]++                             pProps :: Parser Token [Prop]+                             pProps  = (f.concat) <$> (pSpec '[' *> pListSep (pSpec ',') pProp <* pSpec ']')+                                 where f ps = nub (ps ++ concat [[Uni, Inj] | null ([Sym, Asy]>-ps)])+                             pProp :: Parser Token [Prop]+                             pProp   = k [Uni] "UNI" <|> k [Inj] "INJ" <|> k [Sur] "SUR" <|> k [Tot] "TOT" <|>+                                       k [Sym] "SYM" <|> k [Asy] "ASY" <|> k [Trn] "TRN" <|>+                                       k [Rfx] "RFX" <|> k [Irf] "IRF" <|> k [Sym, Asy] "PROP"+                                 where k obj str = f <$> pKey str where f _ = obj+                             pPragma :: Parser Token [String]+                             pPragma = pKey "PRAGMA" *> pList1 pString+                             pFun :: Parser Token [Prop]+                             pFun    = []        <$ pKey "*"  <|> +                                       [Uni,Tot] <$ pKey "->" <|>+                                       [Sur,Inj] <$ pKey "<-" <|>+                                       (rbld     <$  pSpec '['  +                                                 <*> (pMult (Sur,Inj) `opt` [])+                                                 <*  pKey "-"+                                                 <*> (pMult (Tot,Uni) `opt` [])+                                                 <*  pSpec ']'+                                       )       +                                 where +                                   pMult :: (Prop,Prop) -> Parser Token [Prop]+                                   pMult (ts,ui) = rbld  <$> (( []   <$ pKey "0") <|> ([ts] <$ pKey "1") ) +                                                         <*  pKey ".."+                                                         <*> (( [ui] <$ pKey "1") <|> ([]   <$ pKey "*" )) <|>+                                                   [] <$ pKey "*"  <|>+                                                   [ts,ui] <$ pKey "1"+                                   rbld a b = a++b +                                       +   pConceptDef :: Parser Token ConceptDef+   pConceptDef       = Cd <$> pKey_pos "CONCEPT"+                          <*> pConceptName           -- the concept name+                          <*> ((True <$ pKey "BYPLUG") `opt` False)+                          <*> pString                -- the definition text+                          <*> ((pKey "TYPE" *> pString) `opt` "")     -- the type of the concept.+                          <*> (pString `opt` "")     -- a reference to the source of this definition.++   pGenDef :: Parser Token P_Gen+   pGenDef           = rebuild <$> pKey_pos "SPEC"     <*> pConceptRef <* pKey "ISA" <*> pConceptRef <|>  -- SPEC is obsolete syntax. Should disappear!+                       rebuild <$> pKey_pos "CLASSIFY" <*> pConceptRef <* pKey "ISA" <*> pConceptRef <|>+                       pClassify+                       where rebuild p spc gen = PGen{gen_spc=spc, gen_gen=gen, gen_fp =p}++   -- | A identity definition looks like:   IDENT onNameAdress : Person(name, address),+   -- which means that name<>name~ /\ address<>addres~ |- I[Person].+   -- The label 'onNameAddress' is used to refer to this identity.+   -- You may also use an expression on each attribute place, for example: IDENT onpassport: Person(nationality, passport;documentnr),+   -- which means that nationality<>nationality~ /\ passport;documentnr<>(passport;documentnr)~ |- I[Person].+   pIndex :: Parser Token P_IdentDef+   pIndex  = identity <$ pKey "IDENT" <*> pLabel <*> pConceptRefPos <* pSpec '(' <*> pList1Sep (pSpec ',') pIndSegment <* pSpec ')'+       where identity :: Label -> (P_Concept, Origin) -> [P_IdentSegment] -> P_IdentDef +             identity (Lbl nm _ _) (c, orig) ats+              = P_Id { ix_pos = orig+                     , ix_lbl = nm+                     , ix_cpt = c+                     , ix_ats = ats+                     }++             pIndSegment :: Parser Token P_IdentSegment+             pIndSegment = P_IdentExp <$> pIndAtt+             +             pIndAtt :: Parser Token P_ObjectDef+             pIndAtt  = attL <$> pLabelProps <*> pTerm <|>+                        att <$> pTerm+                 where attL (Lbl nm p strs) attexpr =+                          P_Obj { obj_nm   = nm+                                , obj_pos  = p+                                , obj_ctx  = attexpr +                                , obj_msub = Nothing+                                , obj_strs = strs+                                }+                       att attexpr =+                           P_Obj { obj_nm   = ""+                                 , obj_pos  = Origin "pIndAtt CC664"+                                 , obj_ctx  = attexpr +                                 , obj_msub = Nothing+                                 , obj_strs = []+                                 }++   -- | A view definition looks like:+   --      VIEW onSSN: Person("social security number":ssn)+   -- or+   --      VIEW SaveAdlFile: SaveAdlFile(PRIMHTML "<a href='../../index.php?operation=2&file=", filepath , filename+   --      ,PRIMHTML "&userrole=", savecontext~;sourcefile;uploaded~;userrole+   --      ,PRIMHTML "'>", filename/\V[SaveAdlFile*FileName], PRIMHTML "</a>")+   -- which can be used to define a proper user interface by assigning labels and markup to the attributes in a view.+   pViewDef :: Parser Token P_ViewDef+   pViewDef  = vd <$ (pKey "VIEW" <|> pKey "KEY") <*> pLabelProps <*> pConceptOneRefPos <* pSpec '(' <*> pList1Sep (pSpec ',') pViewSegment <* pSpec ')'+       where vd :: Label -> (P_Concept, Origin) -> [P_ViewSegment] -> P_ViewDef +             vd (Lbl nm _ _) (c, orig) ats+                 = P_Vd { vd_pos = orig+                        , vd_lbl = nm+                        , vd_cpt = c+                        , vd_ats = [ case viewSeg of+                                        P_ViewExp x       -> if null (obj_nm x) then P_ViewExp $ x{obj_nm=show i} else P_ViewExp x +                                        P_ViewText _ -> viewSeg +                                        P_ViewHtml _ -> viewSeg +                                   | (i,viewSeg)<-zip [(1::Integer)..] ats]+                        } -- nrs also count text segments but they're are not important anyway+             pViewSegment :: Parser Token P_ViewSegment+             pViewSegment = P_ViewExp  <$> pViewAtt <|> +                            P_ViewText <$ pKey "TXT" <*> pString <|>+                            P_ViewHtml <$ pKey "PRIMHTML" <*> pString+             pViewAtt :: Parser Token P_ObjectDef+             pViewAtt = rebuild <$> optional pLabelProps <*> pTerm+                 where+                   rebuild mLbl attexpr =+                     case mLbl of+                       Just (Lbl nm p strs) ->+                               P_Obj { obj_nm   = nm+                                     , obj_pos  = p+                                     , obj_ctx  = attexpr +                                     , obj_msub = Nothing+                                     , obj_strs = strs+                                     }+                       Nothing ->+                               P_Obj { obj_nm   = ""+                                     , obj_pos  = Origin "pViewAtt CCv221.hs"+                                     , obj_ctx  = attexpr +                                     , obj_msub = Nothing+                                     , obj_strs = []+                                     }++   pInterface :: Parser Token P_Interface+   pInterface = lbl <$> (pKey "INTERFACE" *> pADLid_val_pos) <*>+                        (pParams `opt` [])                   <*>       -- a list of expressions, which say which relations are editable within this service.+                                                                       -- either  Prel _ nm+                                                                       --       or  PTrel _ nm sgn+                        (pArgs   `opt` [])                   <*>  +                        (pRoles  `opt` [])                   <*>  +                        (pKey ":" *> pTerm)                  <*>  +                        pSubInterface+       where lbl :: (String, Origin) -> [TermPrim] -> [[String]] -> [String] -> (Term TermPrim) -> P_SubInterface -> P_Interface+             lbl (nm,p) params args roles expr sub+                = P_Ifc { ifc_Name   = nm+                        , ifc_Params = params+                        , ifc_Args   = args+                        , ifc_Roles  = roles+                        , ifc_Obj    = P_Obj { obj_nm   = nm    +                                             , obj_pos  = p+                                             , obj_ctx  = expr+                                             , obj_msub = Just sub+                                             , obj_strs = args+                                             }+                        , ifc_Pos    = p+                        , ifc_Prp    = ""   --TODO: Nothing in syntax defined for the purpose of the interface.+                        }+             pParams = pSpec '(' *> pList1Sep (pSpec ',') pRelSign          <* pSpec ')' +             pArgs   = pSpec '{' *> pList1Sep (pSpec ',') (pList1 pADLid)   <* pSpec '}'+             pRoles  = pKey "FOR" *> pList1Sep (pSpec ',') pADLid++   pSubInterface :: Parser Token P_SubInterface +   pSubInterface = P_Box <$> pKey_pos "BOX" <*> pBox +                   <|> rebuild <$ pKey "INTERFACE" <*> pADLid_val_pos  +      where+        rebuild (n,p) = P_InterfaceRef p n++   pObjDef :: Parser Token P_ObjectDef+   pObjDef            = obj <$> pLabelProps+                            <*> pTerm            -- the context expression (for example: I[c])+                            <*> optional pSubInterface  -- the optional subinterface +                        where obj (Lbl nm pos' strs) expr msub  = +                                P_Obj { obj_nm   = nm+                                      , obj_pos  = pos'+                                      , obj_ctx  = expr+                                      , obj_msub = msub +                                      , obj_strs = strs+                                      }+   pBox :: Parser Token [P_ObjectDef]+   pBox              = pSpec '[' *> pList1Sep (pSpec ',') pObjDef <* pSpec ']'++   pSqlplug :: Parser Token P_ObjectDef+   pSqlplug          = pKey_pos "SQLPLUG" *> pObjDef++   pPhpplug :: Parser Token P_ObjectDef+   pPhpplug          = pKey_pos "PHPPLUG" *> pObjDef++   pPurpose :: Parser Token PPurpose+   pPurpose          = rebuild <$> pKey_pos "PURPOSE"  -- "EXPLAIN" has become obsolete+                               <*> pRef2Obj+                               <*> optional pLanguageRef+                               <*> optional pTextMarkup+                               <*> ((pKey "REF" *> pString) `opt` [])+                               <*> pExpl      +        where+          rebuild orig obj lang fmt ref str+              = PRef2 orig obj (P_Markup lang fmt str) ref+          pRef2Obj :: Parser Token PRef2Obj+          pRef2Obj = PRef2ConceptDef  <$ pKey "CONCEPT"   <*> pConceptName <|>+                     PRef2Declaration <$ pKey "RELATION"  <*> pRelSign     <|>+                     PRef2Rule        <$ pKey "RULE"      <*> pADLid       <|>+                     PRef2IdentityDef <$ pKey "IDENT"     <*> pADLid       <|>  +                     PRef2ViewDef     <$ pKey "VIEW"      <*> pADLid       <|>  +                     PRef2Pattern     <$ pKey "PATTERN"   <*> pADLid       <|>+                     PRef2Process     <$ pKey "PROCESS"   <*> pADLid       <|>+                     PRef2Interface   <$ pKey "INTERFACE" <*> pADLid       <|>+                     PRef2Context     <$ pKey "CONTEXT"   <*> pADLid++   pPopulation :: Parser Token P_Population+   pPopulation = prelpop <$> pKey_pos "POPULATION" <*> pRelSign     <* pKey "CONTAINS" <*> pContent <|>+                 pcptpop <$> pKey_pos "POPULATION" <*> pConceptName <* pKey "CONTAINS" <*> (pSpec '[' *> pListSep pComma pValue <* pSpec ']')+       where+         prelpop :: Origin -> TermPrim -> Pairs -> P_Population+         prelpop orig (Prel _ nm) contents+          = P_RelPopu { p_rnme   = nm+                      , p_orig   = orig+                      , p_popps  = contents+                      }+         prelpop orig (PTrel _ nm sgn) contents+          = P_TRelPop { p_rnme   = nm+                      , p_type   = sgn+                      , p_orig   = orig+                      , p_popps  = contents+                      }+         prelpop _ expr _ = fatal 429 ("Expression "++show expr++" should never occur in prelpop.")+         pcptpop :: Origin -> String -> [String] -> P_Population+         pcptpop orig cnm contents +          = P_CptPopu { p_cnme   = cnm+                      , p_orig   = orig+                      , p_popas  = contents+                      }++   pRoleRelation :: Parser Token P_RoleRelation+   pRoleRelation      = rr <$> pKey_pos "ROLE"              <*>+                               pList1Sep (pSpec ',') pADLid <*+                               pKey "EDITS"                 <*>+                               pList1Sep (pSpec ',') pRelSign+                        where rr p roles rels = P_RR roles rels p++   pRoleRule :: Parser Token RoleRule+   pRoleRule         = rr <$> pKey_pos "ROLE"               <*>+                              pList1Sep (pSpec ',') pADLid  <*+                              pKey "MAINTAINS"              <*>+                              pList1Sep (pSpec ',') pADLid +                       where rr p roles rulIds = Maintain roles rulIds p++   pPrintThemes :: Parser Token [String]+   pPrintThemes = pKey "THEMES" +               *> pList1Sep (pSpec ',') pConceptName  -- Patterns, processes and concepts share the same name space, so these names must be checked whether the processes and patterns exist.+   pMeaning :: Parser Token PMeaning+   pMeaning = rebuild <$  pKey "MEANING" +                      <*> optional pLanguageRef+                      <*> optional pTextMarkup+                      <*> (pString <|> pExpl)+      where rebuild lang fmt mkup =+               PMeaning (P_Markup lang fmt mkup)+   pMessage :: Parser Token PMessage+   pMessage = rebuild <$ pKey "MESSAGE" +                      <*> optional pLanguageRef+                      <*> optional pTextMarkup+                      <*> (pString <|> pExpl)+      where rebuild lang fmt mkup =+               PMessage (P_Markup lang fmt mkup)+                              +{-  Basically we would have the following expression syntax:+pRule ::= pTrm1   "="    pTerm                           |+          pTrm1   "|-"   pTerm                           |+          pTrm1 .+pTerm ::= pList1Sep "/\\" pTrm2                          |+          pList1Sep "\\/" pTrm2                          |+          pTrm2 .+pTrm2 ::= pTrm3    "-"    pTrm3                          |+          pTrm3 .+pTrm3 ::= pTrm4   "\\"   pTrm4                           |+          pTrm4   "/"    pTrm4                           |+          pTrm4 .+pTrm4 ::= pList1Sep ";" pTrm5                            |+          pList1Sep "!" pTrm5                            |+          pList1Sep "*" pTrm5                            |+          pTrm5 .+pTrm5 ::= "-"     pTrm6                                  |+          pTrm6   pSign                                  |+          pTrm6   "~"                                    |+          pTrm6   "*"                                    |+          pTrm6   "+"                                    |+          pTrm6 .+pTrm6 ::= pRelation                                      |+          "("   pTerm   ")" .+In practice, we have it a little different.+ - In order to avoid "associative" brackets, we parse the associative operators "\/", "/\", ";", and "!" with pList1Sep. That works.+ - We would like the user to disambiguate between "=" and "|-" by using brackets. +-}+++{- In theory, the expression is parsed by:+   pRule :: Parser Token (Term TermPrim)+   pRule  =  fEequ <$> pTrm1  <*>  pKey_pos "="   <*>  pTerm   <|>+             fEimp <$> pTrm1  <*>  pKey_pos "|-"  <*>  pTerm   <|>+             pTrm1+             where fequ  lExp orig rExp = Pequ orig lExp rExp+                   fEimp lExp orig rExp = Pimp orig lExp rExp+-- However elegant, this solution needs to be left-factored in order to get a performant parser.+-}+   pRule :: Parser Token (Term TermPrim)+   pRule  =  pTerm <??> (fEqu  <$> pKey_pos "="  <*> pTerm <|>+                         fImpl <$> pKey_pos "|-" <*> pTerm )+             where fEqu  orig rExp lExp = Pequ orig lExp rExp+                   fImpl orig rExp lExp = Pimp orig lExp rExp++{-+   pTrm1 is slightly more complicated, for the purpose of avoiding "associative" brackets.+   The idea is that each operator ("/\\" or "\\/") can be parsed as a sequence without brackets.+   However, as soon as they are combined, brackets are needed to disambiguate the combination.+   There is no natural precedence of one operator over the other.+   Brackets are enforced by parsing the subexpression as pTrm5.+   In order to maintain performance standards, the parser is left factored.+   The functions pars and f have arguments 'combinator' and 'operator' only to avoid writing the same code twice.+-}+   pTerm :: Parser Token (Term TermPrim)+   pTerm   = pTrm2 <??> (f PIsc <$> pars PIsc "/\\" <|> f PUni <$> pars PUni "\\/")+             where pars combinator operator+                    = g <$> pKey_pos operator <*> pTrm2 <*> optional (pars combinator operator)+                             where g orig y Nothing  = (orig, y)+                                   g orig y (Just (org,z)) = (orig, combinator org y z)+                   f combinator (orig, y) x = combinator orig x y++-- The left factored version of difference: (Actually, there is no need for left-factoring here, but no harm either)+   pTrm2 :: Parser Token (Term TermPrim)+   pTrm2   = pTrm3 <??> (f <$> pKey_pos "-" <*> pTrm3)+             where f orig rExp lExp = PDif orig lExp rExp++-- The left factored version of right- and left residuals:+   pTrm3 :: Parser Token (Term TermPrim)+   pTrm3  =  pTrm4 <??> (fRrs <$> pKey_pos "\\"  <*> pTrm4 <|> fLrs <$> pKey_pos "/" <*> pTrm4 )+             where fRrs orig rExp lExp = PRrs orig lExp rExp+                   fLrs orig rExp lExp = PLrs orig lExp rExp++{- by the way, a slightly different way of getting exactly the same result is:+   pTrm3 :: Parser Token (Term TermPrim)+   pTrm3  =  pTrm4 <??> (f <$>  (pKey_val_pos "\\" <|> pKey_val_pos "/") <*> pTrm4 )+             where f ("\\", orig) rExp lExp = PRrs orig lExp rExp+                   f (_   , orig) rExp lExp = PLrs orig lExp rExp+-}++-- composition and relational addition are associative, and parsed similar to union and intersect...+   pTrm4 :: Parser Token (Term TermPrim)+   pTrm4   = pTrm5 <??> (f PCps <$> pars PCps ";" <|> f PRad <$> pars PRad "!" <|> f PPrd <$> pars PPrd "*")+             where pars combinator operator+                    = g <$> pKey_pos operator <*> pTrm5 <*> optional (pars combinator operator)+                             where g orig y Nothing  = (orig, y)+                                   g orig y (Just (org,z)) = (orig, combinator org y z)+                   f combinator (orig, y) x = combinator orig x y++   pTrm5 :: Parser Token (Term TermPrim)+   pTrm5  =  f <$> pList (pKey_val_pos "-") <*> pTrm6  <*> pList ( pKey_val_pos "~" <|> pKey_val_pos "*" <|> pKey_val_pos "+" )+             where f ms pe (("~",_):("~",_):ps) = f ms pe ps                     -- e~  converse       (flip, wok)+                   f ms pe (("~",_):ps) = let x=f ms pe ps in PFlp (origin x) x  -- the type checker requires that the origin of x is equal to the origin of its converse.+                   f ms pe (("*",orig):ps) = PKl0 orig (f ms pe ps)              -- e*  Kleene closure (star)+                   f ms pe (("+",orig):ps) = PKl1 orig (f ms pe ps)              -- e+  Kleene closure (plus)+                   f (_:_:ms) pe ps        = f ms pe ps                          -- -e  complement     (unary minus)+                   f ((_,orig):ms) pe ps   = let x=f ms pe ps in PCpl orig x     -- the type checker requires that the origin of x is equal to the origin of its complement.+                   f _ pe _                = pe++   pTrm6 :: Parser Token (Term TermPrim)+   pTrm6  =  (Prim <$> pRelationRef)  <|>+             PBrk <$>  pSpec_pos '('  <*>  pTerm  <*  pSpec ')'++   pRelationRef :: Parser Token TermPrim+   pRelationRef      = pRelSign                                                                         <|>+                       pid   <$> pKey_pos "I"  <*> optional (pSpec '[' *> pConceptOneRef <* pSpec ']')  <|>+                       pfull <$> pKey_pos "V"  <*> optional pSign                                       <|>+                       singl <$> pAtom_val_pos <*> optional (pSpec '[' *> pConceptOneRef <* pSpec ']')+                       where pid orig Nothing = PI orig+                             pid orig (Just c)= Pid orig c+                             pfull orig Nothing = PVee orig+                             pfull orig (Just (P_Sign src trg, _)) = Pfull orig src trg+                             singl (nm,orig) x  = Patm orig nm x++   pRelSign :: Parser Token TermPrim+   pRelSign          = prel  <$> pVarid_val_pos <*> optional pSign+                       where prel (nm,orig) Nothing = Prel orig nm+                             prel (nm,_) (Just (sgn,orig)) = PTrel orig nm sgn+                                                                 +   pSign :: Parser Token (P_Sign,Origin)+   pSign = rebuild <$> pSpec_pos '[' <*> pConceptOneRef <*> optional (pKey "*" *> pConceptOneRef) <* pSpec ']'+      where+        rebuild :: Origin -> P_Concept -> Maybe P_Concept -> (P_Sign,Origin)+        rebuild orig a mb+         = case mb of +             Just b  -> (P_Sign a b, orig)+             Nothing -> (P_Sign a a, orig)+   +   pConceptName ::   Parser Token String+   pConceptName    = pConid <|> pString++   pConceptRef ::    Parser Token P_Concept+   pConceptRef     = PCpt <$> pConceptName++   pConceptOneRef :: Parser Token P_Concept+   pConceptOneRef  = (P_Singleton <$ pKey "ONE") <|> pConceptRef++   pConceptRefPos :: Parser Token (P_Concept, Origin)+   pConceptRefPos     = conid <$> pConid_val_pos   <|>   conid <$> pString_val_pos+                        where conid :: (String, Origin) ->  (P_Concept, Origin)+                              conid (c,orig) = (PCpt c, orig)++   pConceptOneRefPos :: Parser Token (P_Concept, Origin)+   pConceptOneRefPos  = singl <$> pKey_pos "ONE"   <|>   conid <$> pConid_val_pos   <|>   conid <$> pString_val_pos+                        where singl :: Origin ->  (P_Concept, Origin)+                              singl orig     = (P_Singleton, orig)+                              conid :: (String, Origin) ->  (P_Concept, Origin)+                              conid (c,orig) = (PCpt c, orig)++--  (SJ) Why does a label have (optional) strings?+--  (GM) This is a binding mechanism for implementation specific properties, such as SQL/PHP plug,PHP web app,etc.+--  (SJ April 15th, 2013) Since KEY has been replaced by IDENT and VIEW, there is a variant with props  (pLabelProps) and one without (pLabel).+   pLabelProps :: Parser Token Label+   pLabelProps       = lbl <$> pADLid_val_pos+                           <*> (pArgs `opt` [])+                           <*  pKey_pos ":"+                       where lbl :: (String, Origin) -> [[String]] -> Label+                             lbl (nm,pos') strs = Lbl nm pos' strs+                             pArgs = pSpec '{' *> pList1Sep (pSpec ',') (pList1 pADLid) <* pSpec '}'++   pLabel :: Parser Token Label+   pLabel       = lbl <$> pADLid_val_pos <*  pKey ":"+                  where lbl :: (String, Origin) -> Label+                        lbl (nm,pos') = Lbl nm pos' []++   pContent :: Parser Token Pairs+   pContent          = pSpec '[' *> pListSep pComma pRecord <* pSpec ']'+                   <|> pSpec '[' *> pListSep (pKey ";") pRecordObs <* pSpec ']' --obsolete+       where+       pRecord = mkPair<$> pValue <* pKey "*" <*> pValue+       pRecordObs = mkPair<$ pSpec '(' <*> pString <* pComma   <*> pString <* pSpec ')' --obsolete+   pValue :: Parser Token String+   pValue  = pAtom <|> pConid <|> pVarid <|> pInteger <|> ((++)<$>pInteger<*>pConid) <|> ((++)<$>pInteger<*>pVarid)++++   pADLid :: Parser Token String+   pADLid            = pVarid <|> pConid <|> pString++   pADLid_val_pos :: Parser Token (String, Origin)+   pADLid_val_pos    = pVarid_val_pos <|> pConid_val_pos <|> pString_val_pos++   optional :: (Sequence p, Alternative p) => p a -> p (Maybe a)+   optional a        = Just <$> a <|> pSucceed Nothing+++   get_tok_pos :: Token -> Origin+   get_tok_pos     (Tok _ _ s l f) = FileLoc(FilePos (f,l,s))+   get_tok_val_pos :: Token -> (String, Origin)+   get_tok_val_pos (Tok _ _ s l f) = (s,FileLoc(FilePos (f,l,s)))++++   gsym_pos :: IsParser p Token => TokenType -> String -> String -> p Origin+   gsym_pos kind val' val2' = get_tok_pos <$> pSym (Tok kind val' val2' noPos "")++   gsym_val_pos :: IsParser p Token => TokenType -> String -> String -> p (String,Origin)+   gsym_val_pos kind val' val2' = get_tok_val_pos <$> pSym (Tok kind val' val2' noPos "")++   pKey_pos :: String -> Parser Token Origin+   pKey_pos keyword  =   gsym_pos TkKeyword   keyword   keyword+   pSpec_pos :: Char -> Parser Token Origin+   pSpec_pos s       =   gsym_pos TkSymbol    [s]       [s]++   pString_val_pos, pVarid_val_pos, pConid_val_pos, pAtom_val_pos ::  IsParser p Token => p (String,Origin)+   pString_val_pos    =   gsym_val_pos TkString    ""        "?STR?"+   pVarid_val_pos     =   gsym_val_pos TkVarid     ""        "?LC?"+   pConid_val_pos     =   gsym_val_pos TkConid     ""        "?UC?"+   pAtom_val_pos      =   gsym_val_pos TkAtom      ""        ""+   pKey_val_pos ::  IsParser p Token => String -> p (String,Origin)+   pKey_val_pos keyword = gsym_val_pos TkKeyword   keyword   keyword+--   pSpec_val_pos ::  IsParser p Token => Char -> p (String,Origin)+--   pSpec_val_pos s      = gsym_val_pos TkSymbol    [s]       [s]
+ src/lib/DatabaseDesign/Ampersand/Input/ADL1/UU_BinaryTrees.hs view
@@ -0,0 +1,70 @@+module DatabaseDesign.Ampersand.Input.ADL1.UU_BinaryTrees 
+   ( BinSearchTree(..)
+   , tab2tree
+   , btFind
+   , btLocateIn
+   )
+   where
+
+   data BinSearchTree av
+    = Node (BinSearchTree av) av (BinSearchTree av)
+    | Nil
+
+
+   tab2tree :: [av] -> BinSearchTree av
+   tab2tree tab = tree
+    where
+     (tree,[]) = sl2bst (length tab) tab
+     sl2bst 0 list     = (Nil   , list)
+     sl2bst n list     
+      = let 
+         ll = (n - 1) `div` 2 ; rl = n - 1 - ll
+         (lt,a:list1) = sl2bst ll list 
+         (rt,  list2) = sl2bst rl list1
+        in (Node lt a rt, list2)
+
+
+
+   btFind :: (a -> b -> Ordering) -> BinSearchTree (a, c) -> b -> Maybe c
+   btLocateIn :: (a -> b -> Ordering) -> BinSearchTree a      -> b -> Maybe a
+   btFind     = btLookup fst snd
+   btLocateIn = btLookup id id
+   btLookup  key val cmp (Node Nil  kv Nil)
+     =  let comp = cmp (key kv)
+            r    = val kv
+        in \i -> case comp i of
+                 LT -> Nothing    
+                 EQ -> Just r
+                 GT -> Nothing 
+
+   btLookup key val cmp (Node left kv Nil) 
+     =  let comp = cmp (key kv)
+            findleft = btLookup key val cmp left
+            r    = val kv
+        in \i -> case comp i of
+                 LT -> Nothing    
+                 EQ -> Just r
+                 GT -> findleft i 
+
+   btLookup key val cmp (Node Nil kv right )
+     =  let comp      = cmp (key kv)
+            findright = btLookup key val cmp right
+            r         = val kv
+            in \i -> case comp i of
+                     LT -> findright i   
+                     EQ -> Just r
+                     GT -> Nothing 
+
+   btLookup key val cmp (Node left kv right)
+     =  let comp = cmp (key kv)
+            findleft  = btLookup key val cmp left
+            findright = btLookup key val cmp right
+            r    = val kv
+        in \i -> case comp i of
+                 LT -> findright i    
+                 EQ -> Just r
+                 GT -> findleft i
+
+   btLookup _ _ _ Nil   =  const Nothing
+
+
+ src/lib/DatabaseDesign/Ampersand/Input/ADL1/UU_Parsing.hs view
@@ -0,0 +1,1142 @@+{-# LANGUAGE RankNTypes, ExistentialQuantification, FunctionalDependencies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+module DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing 
+       (parseIO,parse,getMsgs,evalSteps
+       , Steps(..),Pair(..)
+                      ,Symbol(..),pPacked
+                      ,Parser
+                      ,pList,pListSep,pList1,pList1Sep,pSym
+                      ,opt
+                      ,(<??>), (<**>), Sequence((<$>), (<$), (<*>), (<*), (*>), pSucceed )
+                      ,Alternative(..)
+                      ,IsParser
+                      ,Message(..))
+--   (
+--   Result,
+--   mapOnePars,
+--   libSucceed,
+--   InputState(..),
+--   OutputState(..),
+--   Sequence(..),
+--   Alternative(..),
+--   Symbol(..),
+--   SymParser(..),
+--   SplitParser(..),
+--   IsParser,
+--   RealParser(..),
+--   RealRecogn(..),
+--   Either'(..),
+--   ParsRec(..),
+--   Message(..),
+--
+--   AnaParser,
+--   Parser,
+--   Steps(..),
+--   Pair(..),
+--   Exp(..),
+--   pLocate,
+--   pToks,
+--   list_of ,
+--   usealg ,
+--   pMerged,
+--   pLength,
+--   (<||>) ,
+--   pAnySym,
+--   pAny ,
+--   pChainl,
+--   pChainl_ng,
+--   pChainl_gr,
+--   pChainr,
+--   pChainr_ng,
+--   pChainr_gr,
+--   pList1Sep,
+--   pList1Sep_ng,
+--   pList1Sep_gr,
+--   pListSep,
+--   pListSep_ng,
+--   pListSep_gr,
+--   pList1,
+--   pList1_ng,
+--   pList1_gr,
+--   pList,
+--   pList_ng,
+--   pList_gr,
+--   list_alg,
+--   pFoldr1Sep,
+--   pFoldr1Sep_ng,
+--   pFoldr1Sep_gr,
+--   pFoldrSep,
+--   pFoldrSep_ng,
+--   pFoldrSep_gr,
+--   pFoldr1,
+--   pFoldr1_ng,
+--   pFoldr1_gr,
+--   pFoldr,
+--   pFoldr_gr,
+--   pFoldr_ng,
+--   pPacked,
+--   (<?>),
+--   (<??>),
+--   (<$$>),
+--   (<**>),
+--  -- (*>),
+--  -- (<*),
+--  -- (<$),
+--   (<+>),
+--   asOpt,
+--   asList1,
+--   asList,
+--   opt ,
+--   pExcept,
+--   (<..>) ,
+--   mnz,
+--   acceptsepsilon,
+--   p2p,pPermsSep,pPerms,add,(~$~),(~*~),
+--   systemerror,
+--   usererror,
+--   handleEof,
+--   pDynL,
+--   pDynE,
+--   -- getErrors,
+--  -- getMsgs,
+--   parse ,parsebasic,parseIO,
+--   evalSteps,evalStepsIO,getMsgs,
+--  -- pCostRange,
+--  -- pCostSym,
+--  -- pSym,
+--  -- pRange,
+--  -- getfirsts,
+--  -- setfirsts,
+--  -- (<*>),
+--  -- pSucceed,
+--  -- pLow,
+--  -- (<$>),
+--  -- (<|>),
+--  -- pFail,
+--   pMap,
+--   pWrap,
+--   val
+--   )
+   where
+   import Data.Maybe
+   --import PrelGHC
+   --import IOExts
+   import System.IO.Unsafe
+   import DatabaseDesign.Ampersand.Basics  
+   import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)
+   
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Input.ADL1.UU_Parsing"
+
+   btLookup :: BinSearchTree (a -> Ordering) (Maybe b) -> a -> Maybe b
+   tab2tree :: Ord a => [(SymbolR a,b)] -> BinSearchTree (a -> Ordering) b
+   pLocate :: (Alternative a, SymParser a b, Sequence a) => [[b]] -> a [b]
+   pToks :: (Sequence a, SymParser a b) => [b] -> a [b]
+   list_of :: Sequence a => a b -> ([c],a ([b] -> [b]),d -> d)
+   usealg :: Sequence a => (b -> c,d) -> a b -> (d,a c,e -> e)
+   pMerged :: (Symbol b, Sequence a, Alternative a, Show (Exp b), SymParser a b, SplitParser a) => c -> (d,a (d -> d),c -> d -> e) -> a e
+   (<||>) :: (Sequence a, Alternative a) => (b,a (c -> c),d -> e -> f) -> (g,a (h -> h),f -> i -> j) -> ((b,g),a ((c,h) -> (c,h)),d -> (e,i) -> j)
+   pAnySym :: (Alternative a, SymParser a b) => [b] -> a b
+   pAny :: Alternative a => (b -> a c) -> [b] -> a c
+   pChainl :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
+   pChainl_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
+   pChainl_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
+   pChainr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
+   pChainr_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Alternative a, Sequence a) => a (c -> c -> c) -> a c -> a c
+   pChainr_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
+   pList1Sep :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
+   pList1Sep_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
+   pList1Sep_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
+   pListSep :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
+   pListSep_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Alternative a, Sequence a) => a c -> a d -> a [d]
+   pListSep_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
+   pList1 :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => a c -> a [c]
+   pList1_ng :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => a c -> a [c]
+   pList1_gr :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => a c -> a [c]
+   pList :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => a c -> a [c]
+   pList_ng :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => a c -> a [c]
+   pList_gr :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => a c -> a [c]
+   list_alg :: (a -> [a] -> [a],[b])
+   pFoldr1Sep :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
+   pFoldr1Sep_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
+   pFoldr1Sep_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
+   pFoldrSep :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
+   pFoldrSep_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Alternative a, Sequence a) => (c -> d -> d,d) -> a e -> a c -> a d
+   pFoldrSep_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
+   pFoldr1 :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => (c -> d -> d,d) -> a c -> a d
+   pFoldr1_ng :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => (c -> d -> d,d) -> a c -> a d
+   pFoldr1_gr :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => (c -> d -> d,d) -> a c -> a d
+   pFoldr :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => (c -> d -> d,d) -> a c -> a d
+   pFoldr_gr :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => (c -> d -> d,d) -> a c -> a d
+   pFoldr_ng :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => (c -> d -> d,d) -> a c -> a d
+   pPacked :: Sequence a => a b -> a c -> a d -> a d
+   (<?>) :: SymParser a b => a c -> String -> a c
+   (<??>) :: (Symbol b, Sequence a, Alternative a, Show (Exp b), SymParser a b, SplitParser a) => a c -> a (c -> c) -> a c
+   (<$$>) :: Sequence a => (b -> c -> d) -> a c -> a (b -> d)
+   (<**>) :: Sequence a => a b -> a (b -> c) -> a c
+   (<+>) :: Sequence a => a b -> a c -> a (b,c)
+   asOpt :: SymParser a b => Exp b -> a c -> a c
+   asList1 :: SymParser a b => Exp b -> a c -> a c
+   asList :: SymParser a b => Exp b -> a c -> a c
+   opt :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> c -> a c
+   pExcept :: (Alternative a, SymParser a b, Eq (SymbolR b), Symbol b) => (b,b,b) -> [b] -> a b
+   (<..>) :: SymParser a b => b -> b -> a b
+   mnz :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b)) => a c -> d -> d
+   acceptsepsilon :: SplitParser a => a b -> Bool
+   p2p :: (Alternative a, Sequence a) => a b -> a c -> Perms a d -> a d
+   pPermsSep :: (Alternative a, Sequence a) => a b -> Perms a c -> a c
+   pPerms :: (Alternative a, Sequence a) => Perms a b -> a b
+   add :: Sequence a => Perms a (b -> c) -> (Maybe (a b),Maybe (a b)) -> Perms a c
+   (~$~) :: (Sequence a, SplitParser a) => (b -> c) -> a b -> Perms a c
+   (~*~) :: (Sequence a, SplitParser a) => Perms a (b -> c) -> a b -> Perms a c
+   systemerror :: String -> String -> a
+   usererror :: String -> a
+   except :: Symbol a => SymbolR a -> [a] -> [SymbolR a]
+   symRS :: Ord a => SymbolR a -> a -> Ordering
+   symInRange :: Ord a => SymbolR a -> a -> Bool
+   mk_range :: Ord a => a -> a -> SymbolR a
+   mergeTables :: (Symbol a, Ord b) => [(SymbolR a,ParsRec c d b e)] -> [(SymbolR a,ParsRec c d b e)] -> [(SymbolR a,ParsRec c d b e)]
+   nat_add :: Nat -> Nat -> Nat
+   nat_min :: Nat -> Nat -> (Nat,(a,a) -> (a,a))
+   nat_le :: Nat -> Nat -> Bool
+   lib_correct :: Ord a => (b -> c -> Steps d a) -> (b -> c -> Steps d a) -> b -> c -> Steps d a
+   mkParser :: InputState a b => Maybe (Bool,Either c (ParsRec a d b c)) -> OneDescr a d b c -> AnaParser a d b c
+   mapOnePars :: (ParsRec a b c d -> ParsRec e f c g) -> (Nat -> Nat) -> OneDescr a b c d -> OneDescr e f c g
+   anaSetFirsts :: InputState a b => Exp b -> AnaParser a c b d -> AnaParser a c b d
+   anaGetFirsts :: AnaParser a b c d -> Exp c
+   pLength :: AnaParser a b c d -> Nat
+   anaCostSym :: SymParser a b => Int{-I-} -> b -> b -> a b
+   anaCostRange :: InputState a b => Int{-I-} -> b -> SymbolR b -> AnaParser a c b b
+   orOneOneDescr :: (Ord a, Ord (Exp a), Eq (SymbolR a)) => OneDescr b c a d -> OneDescr b c a d -> Bool -> OneDescr b c a d
+   seqZeroZero :: Maybe (Bool,Either a b) -> Maybe (Bool,Either c (ParsRec d e f c)) -> (a -> ParsRec d e f c -> g) -> (b -> ParsRec d e f c -> g) -> (a -> c -> h) -> Maybe (Bool,Either h g)
+   anaSeq :: (Ord (Exp a), Eq (SymbolR a), InputState b a) => (c -> ParsRec d e a f -> ParsRec b g a h) -> (ParsRec i j a c -> ParsRec d e a f -> ParsRec b g a h) -> (c -> f -> h) -> AnaParser i j a c -> AnaParser d e a f -> AnaParser b g a h
+   anaOr :: (InputState a b, Ord (Exp b), Eq (SymbolR b), Show (Exp b)) => AnaParser a c b d -> AnaParser a c b d -> AnaParser a c b d
+   anaDynN :: InputState a b => Exp b -> Nat -> SymbolR b -> TableEntry a c b d -> AnaParser a c b d
+   anaDynL :: ParsRec a b c d -> AnaParser a b c d
+   anaDynE :: ParsRec a b c d -> AnaParser a b c d
+   anaLow :: a -> AnaParser b c d a
+   anaSucceed :: a -> AnaParser b c d a
+   pEmpty :: ParsRec a b c d -> (Bool,Either d (ParsRec a b c d)) -> AnaParser a b c d
+   noOneParser :: OneDescr a b c d
+   anaFail :: AnaParser a b c d
+   traverse :: Pairs -> Pairs -> Steps a b -> Int{-I-} -> Pairs
+   libCorrect :: Ord a => Steps b a -> Steps c a -> (b -> d) -> (c -> d) -> Steps d a
+   libBest' :: Ord a => Steps b a -> Steps c a -> (b -> d) -> (c -> d) -> Steps d a
+   libBest :: Ord a => Steps b a -> Steps b a -> Steps b a
+   eor :: Ord (Exp a) => Exp a -> Exp a -> Exp a
+   addexpecting :: Ord a => Exp a -> Steps b a -> Steps b a
+   marks :: String
+   addToMessage :: Ord (Exp a) => Message a -> Exp a -> Message a
+   getStart :: Message a -> Exp a
+   getMsgs :: Steps a b -> [Message b]
+   evalStepsIO :: Symbol a => Steps b a -> IO b
+   evalSteps :: Steps a b -> a
+   hasSuccess :: Steps a b -> Bool
+   starting :: Steps a b -> Exp b
+   libFail :: ParsRec a b c d
+   libOr :: Ord a => ParsRec b c a d -> ParsRec b c a d -> ParsRec b c a d
+   libSeqR :: ParsRec a b c d -> ParsRec a e c f -> ParsRec a e c f
+   libSeqL :: ParsRec a b c d -> ParsRec a e c f -> ParsRec a b c d
+   libDollarR :: a -> ParsRec b c d e -> ParsRec b c d e
+   libDollarL :: a -> ParsRec b c d e -> ParsRec b f d a
+   libDollar :: OutputState a => (b -> c) -> ParsRec d a e b -> ParsRec d a e c
+   libSeq :: OutputState a => ParsRec b a c (d -> e) -> ParsRec b f c d -> ParsRec b f c e
+   libSucceed :: a -> ParsRec b c d a
+   libInsert :: InputState a b => Int{-I-} -> b -> Exp b -> ParsRec a c b b
+   libAccept :: InputState a b => ParsRec a c b b
+   unR :: RealRecogn a b -> (a b -> Result c b) -> a b -> Result c b
+   unP :: RealParser a b c d -> (d -> b e f -> g) -> (a c -> Result (b e f) c) -> a c -> Result g c
+   pDynN :: InputState a b => Exp b -> Nat -> SymbolR b -> TableEntry a c b d -> AnaParser a c b d
+   pDynL :: ParsRec a b c d -> AnaParser a b c d
+   pDynE :: ParsRec a b c d -> AnaParser a b c d
+   handleEof :: InputState a b => a b -> Steps (Pair (a b) c) b
+   parse :: InputState a b => AnaParser a Pair b c -> a b -> Steps (Pair c (Pair (a b) d)) b
+   parseIO :: InputState a b => AnaParser a Pair b c -> a b -> IO c
+   parsebasic :: InputState a b => ParsRec a Pair b c -> a b -> Steps (Pair c (Pair (a b) d)) b
+   parsebasic (PR ( P rp, _))
+    = rp Pair handleEof
+
+   parseIO (pp) inp
+    = do  (Pair v final) <- evalStepsIO (parsebasic (pars pp) inp) 
+          final `seq` return v -- in order to force the trailing error messages to be printed
+
+   parse (pp)
+    = parsebasic (pars pp) 
+
+   handleEof input = case splitStateE input
+                      of Left'  s  ss  ->  StRepair (deleteCost s)  (Msg ("deleting symbol " ++ show s
+                                                                         , "in unused part of input"
+                                                                         , EStr "eof"
+                                                                         )) (handleEof ss)
+                         Right' final  ->  NoMoreSteps (Pair final undefined)
+
+
+
+
+
+   infixl 2 <?>
+   infixl 3 <|>
+   infixl 4 <*>, <$> , <+>
+   infixl 4 ~*~,  ~$~
+
+   infixl 4 <$, <*, *>, <**>, <??>
+   infixl 2 `opt`
+   infixl 5 <..>
+
+
+
+
+
+   type Parser = AnaParser []  Pair 
+
+   data Pair a r = Pair a r
+
+   data Either' state s = Left' s (state s)
+                        | Right' (state s)
+
+   instance Symbol s => InputState [] s where
+    splitStateE []     = Right' []
+    splitStateE (s:ss) = Left'  s ss
+    splitState  (s:ss) = ({-L-} s, ss{-R-})
+    firstState  []     = Nothing
+    firstState  (s:ss) = Just s
+    getPosition []     = "unexpected end of input"
+    getPosition (s:ss) = "before " ++ show s
+    {-# INLINE splitStateE #-}
+    {-# INLINE splitState  #-}
+    
+   instance OutputState Pair  where
+     acceptR            = Pair
+     nextR       acc  f   ~(Pair a r) = acc  (f a) r  
+     dollarR     acc  f  v = acc  (f v)
+     {-# INLINE acceptR #-}
+     {-# INLINE nextR   #-}
+     {-# INLINE dollarR #-}
+
+   instance (Symbol s, InputState state s, OutputState result) => Sequence (AnaParser state result s)    where
+     (<*>) = anaSeq libDollar  libSeq  ($) 
+     (<* ) = anaSeq libDollarL libSeqL const
+     ( *>) = anaSeq libDollarR libSeqR (flip const) 
+     pSucceed = anaSucceed
+     pLow     = anaLow
+
+   instance (Symbol s, InputState state s, OutputState result) => Alternative (AnaParser state result s) where
+     (<|>) = anaOr
+     pFail = anaFail
+
+   instance (Symbol s, InputState state s, OutputState result) => SymParser (AnaParser state result s) s where
+     pCostRange   = anaCostRange
+     pCostSym     = anaCostSym
+     getfirsts    = anaGetFirsts
+     setfirsts    = anaSetFirsts
+
+   instance (InputState state s, OutputState result, Symbol s) => SplitParser (AnaParser state result s) where
+    getzerop  p = case zerop p of
+                    Nothing     -> Nothing
+                    Just (b,e)  -> Just p {pars=libSucceed `either` id $ e
+                                          ,onep=noOneParser
+                                          }
+    getonep   p = let tab = table (onep p)
+                  in if null tab then Nothing else Just (mkParser Nothing (onep p))
+
+   pDynE = anaDynE
+   pDynL = anaDynL
+   pDynN = anaDynN
+
+
+
+
+
+   class    (Sequence p, Alternative p, SymParser p s, SplitParser p,  Show s) => IsParser p s | p -> s
+
+   instance (Sequence p, Alternative p, SymParser p s, SplitParser p,  Show s) => IsParser p s
+
+   class Sequence p where
+     (<*>) :: p (a->b) -> p a -> p b
+     (<* ) :: p  a     -> p b -> p a
+     ( *>) :: p  a     -> p b -> p b
+     (<$>) ::   (a->b) -> p a -> p b
+     (<$ ) ::   f      -> p a -> p f
+     pSucceed :: a -> p a
+     pLow :: a -> p a
+     f <$> p = pSucceed f <*> p
+     f <$  q = pSucceed f <*  q
+     p <*  q = pSucceed       const  <*> p <*> q
+     p  *> q = pSucceed (flip const) <*> p <*> q
+
+   class Alternative p where
+     (<|>) :: p a -> p a -> p a
+     pFail :: p a
+
+   class SymParser p s | p -> s where
+    pCostRange :: Int{-I-} -> s -> SymbolR s -> p s
+    pCostSym :: Int{-I-} -> s -> s         -> p s
+    pSym ::             s         -> p s
+    pRange ::        s -> SymbolR s -> p s
+    getfirsts ::  p v -> Exp s
+    setfirsts ::  Exp s -> p v ->  p v
+    pSym a       =  pCostSym   5{-I-} a a
+    pRange       =  pCostRange 5{-I-}
+
+   class SplitParser p where
+    getzerop ::  p v -> Maybe (p v)
+    getonep ::  p v -> Maybe (p v)
+
+   class Symbol s => InputState state s where
+    splitStateE :: state s            -> Either' state s
+    splitState :: state s            -> ({-L-} s, state s {-R-})
+    firstState :: state s            -> Maybe s
+    getPosition :: state s            -> String
+
+   class OutputState r  where
+     acceptR ::                              v             -> rest        -> r v rest
+     nextR ::    (a ->     rest -> rest') -> (b -> a)      -> r b rest  -> rest'
+     dollarR ::  (a -> r c rest -> rest') -> (b -> a) -> b -> r c rest  -> rest'
+
+   class (Ord s, Show s) => Symbol s where
+    deleteCost :: s -> Int{-I-}
+    symBefore :: s -> s
+    symAfter :: s -> s
+    deleteCost b = 5{-I-}
+    symBefore  = fatal 398 "You should have made your token type an instance of the Class Symbol. eg by defining symBefore = pred"
+    symAfter   = fatal 399 "You should have made your token type an instance of the Class Symbol. eg by defining symAfter  = succ"
+
+
+
+
+
+   type Result val s = Steps val s
+
+   newtype RealParser    state result s a = P(forall r r' b. (a -> result b r -> r') ->
+                                                             (state s -> Result (result b r) s) ->  state s -> Result r' s)
+
+   newtype RealRecogn    state        s   = R(forall r     . (state s -> Result           r  s) ->  state s -> Result r  s)
+
+   newtype ParsRec       state result s a = PR  ( RealParser  state result s a
+                                                , RealRecogn  state        s
+                                                )
+
+   {-# INLINE unP #-}
+   {-# INLINE unR #-}
+   unP  (P  p) = p
+   unR  (R  p) = p
+
+
+
+
+
+   libAccept            =  PR  (P (\ acc k state ->
+                                   case splitState state of
+                                   ({-L-} s, ss {-R-})  -> OkVal (acc s) (k ss))
+                               ,R (\ k state ->
+                                   case splitState state of
+                                   ({-L-} s, ss {-R-})  ->   Ok (k ss))
+                               )
+   libInsert  c sym  firsts = PR ( P (\acc k state ->  StRepair c (Msg  ("inserting symbol " ++ show sym
+                                                                        , getPosition state
+                                                                        , firsts
+                                                                        )) (val (acc sym) (k state)))
+                                 , R (\    k state ->  StRepair c (Msg  ("inserting symbol " ++ show sym
+                                                                        , getPosition state
+                                                                        , firsts
+                                                                        ))                (k state))
+                                 )
+   {-# INLINE libSeq  #-}
+   {-# INLINE libSeqL #-}
+   {-# INLINE libSeqR #-}
+   {-# INLINE libDollar #-}
+   {-# INLINE libDollarL #-}
+   {-# INLINE libDollarR #-}
+   {-# INLINE libSucceed #-}
+
+   libSucceed v                                 = PR ( P (\ acc -> let accv = val (acc v) in \ k state -> accv (k state))
+                                                     , R id
+                                                     )
+   libSeq  (PR (P pp, R pr)) ~(PR (P qp, R qr)) = PR ( P (\ acc -> pp (nextR acc).qp acceptR)
+                                                     , R (pr.qr)
+                                                     )
+   libDollar f                (PR (P qp, R qr)) = PR ( P (\ acc -> qp (dollarR acc f))
+                                                     , R qr
+                                                     )
+   libDollarL f               (PR (P qp, R qr)) = PR ( P (\ acc -> let accf = val (acc f) in \ k -> qr (accf . k))
+                                                     , R qr
+                                                     )
+   libDollarR f               (PR (P qp, R qr)) = PR (P qp, R qr)
+
+   libSeqL (PR (P pp, R pr)) ~(PR (P qp, R qr)) = PR  ( P (\acc -> pp acc.qr)
+                                                      , R(pr.qr)
+                                                      )
+   libSeqR (PR (P pp, R pr)) ~(PR (P qp, R qr)) = PR  ( P (\acc -> pr.qp acc )
+                                                      , R(pr.qr)
+                                                      )
+   libOr   (PR (P pp, R pr))  (PR (P qp, R qr)) = PR  ( P (\ acc -> let p = pp acc
+                                                                        q = qp acc
+                                                                    in \ k state   -> p  k state `libBest` q  k state)
+                                                      , R (\             k state   -> pr k state `libBest` qr k state)
+                                                      )
+   libFail                                      = PR ( P (\ _ _  _  -> (usererror  "calling an always failing parser"    ))
+                                                     , R (\   _  _  -> (usererror  "calling an always failing recogniser"))
+                                                     )
+         
+
+
+
+
+
+   data Steps val s 
+                = forall a . OkVal           (a -> val)                             (Steps a   s)
+                |            Ok         {                                    rest :: Steps val s}
+                |            Cost       {costing::Int{-I-}                 , rest :: Steps val s}
+                |            StRepair   {costing::Int{-I-}, m :: Message s , rest :: Steps val s}
+                | forall v w.Best       (Steps v s) (Steps val s) (Exp s) ( Steps w s)
+                |            NoMoreSteps val
+   val f (OkVal a rest) = OkVal (f.a) rest
+   val f (Ok      rest) = OkVal  f rest
+   val f (Cost i  rest) = Cost i (val f rest)
+   val f (StRepair c m r) = StRepair c m (val f r)
+   val f (Best l s e r)   = Best l (val f s) e r
+   val f (NoMoreSteps v)  = NoMoreSteps (f v)
+
+   starting (StRepair _ m _ ) = getStart m
+   starting (Best _ _ s _ )   = s
+   starting _                 = systemerror "UU_Parsing" "starting"
+
+   hasSuccess (OkVal _ _ ) = True
+   hasSuccess (Ok      _ ) = True
+   hasSuccess (NoMoreSteps _) = True
+   hasSuccess (Cost i  _    ) = True
+   hasSuccess _               = False
+
+   evalSteps (OkVal v  rest    ) = v (evalSteps rest)
+   evalSteps (Ok       rest    ) =    evalSteps rest
+   evalSteps (Cost  _  rest    ) =    evalSteps rest
+   evalSteps (StRepair _ msg rest    ) =    evalSteps rest
+   evalSteps (Best _   rest _ _) =  evalSteps rest
+   evalSteps (NoMoreSteps v    ) =  v
+
+   evalStepsIO (OkVal v  rest    ) = do arg <- unsafeInterleaveIO (evalStepsIO rest)
+                                        return (v arg)
+   evalStepsIO (Ok       rest    ) = evalStepsIO rest
+
+   evalStepsIO (Cost  _  rest    ) = evalStepsIO rest
+   evalStepsIO (StRepair _ msg rest    ) = do putStr (fatal 519 (show msg)) -- was: do putStr (show msg) -- b.joosten
+                                              evalStepsIO rest
+   evalStepsIO (Best _   rest _ _) =  evalStepsIO rest
+   evalStepsIO (NoMoreSteps v    ) =  return v
+
+   getMsgs (OkVal _        rest) = getMsgs rest
+   getMsgs (Ok             rest) = getMsgs rest
+   getMsgs (Cost _         rest) = getMsgs rest
+   getMsgs (StRepair _ m   rest) = m:getMsgs rest
+   getMsgs (Best _ m _ _)        = getMsgs m
+   getMsgs (NoMoreSteps _      ) = []
+
+   newtype Message s  =  Msg (String, String, Exp s) -- action, position, expecting 
+                         deriving Eq
+   getStart (Msg (_,_,st)) = st
+
+   addToMessage (Msg (act, pos, exp)) more = Msg (act, pos, more `eor` exp)
+
+   marks = '\n':take 60 qmarks
+           where qmarks = '?':qmarks
+
+   instance Symbol s => Show (Message s) where
+    show (Msg (action, position, expecting))  
+      =  "\n" ++ position ++
+         "\nExpecting " ++ show expecting ++
+         "\nTry " ++ action ++ "\n"
+
+   addexpecting more  (StRepair    cost   msg   rest) = StRepair cost (addToMessage msg more) rest
+   addexpecting more  (Best     l    sel  starting r) = Best l (addexpecting more sel) starting r
+   addexpecting more  (OkVal v rest                 ) =  systemerror "UU_Parsing" "addexpecting: OkVal"
+   addexpecting more  (Ok   _                       ) =  systemerror "UU_Parsing" "addexpecting: Ok"
+   addexpecting more  (Cost _ _                     ) =  systemerror "UU_Parsing" "addexpecting: Cost"
+   addexpecting more  _                               =  systemerror "UU_Parsing" "addexpecting: other"
+   data Exp s = ESym (SymbolR s)
+              | EStr String
+              | EOr  [Exp s]
+              | ESeq [Exp s]
+              deriving (Ord, Eq)
+
+   eor p  q  = EOr (merge (tolist p) (tolist q))
+               where merge x@(l:ll) y@(r:rr) = case compare l r of
+                                               LT -> l:( ll `merge`  y)
+                                               GT -> r:( x  `merge` rr)
+                                               EQ -> l:( ll `merge` rr)
+                     merge l [] = l
+                     merge [] r = r
+                     tolist (EOr l) = l
+                     tolist x       = [x]
+
+   instance Symbol s => Show (Exp s) where
+    show (ESym     s)   = show s
+    show (EStr   str)   = str
+    show (EOr     [])   = "Nothing expected "
+    show (EOr    [e])   = show e
+    show (EOr  (e:ee))  = show e ++ " or " ++ show (EOr ee)
+    show (ESeq  seq)    = concatMap show seq
+
+
+
+
+
+
+   libBest ls rs = libBest' ls rs id id
+   libBest' (OkVal v ls) (OkVal w rs) lf rf = Ok (libBest' ls rs (lf.v) (rf.w))
+   libBest' (OkVal v ls) (Ok      rs) lf rf = Ok (libBest' ls rs (lf.v)  rf   )
+   libBest' (Ok      ls) (OkVal w rs) lf rf = Ok (libBest' ls rs  lf    (rf.w))
+   libBest' (Ok      ls) (Ok      rs) lf rf = Ok (libBest' ls rs  lf     rf   )
+   libBest' (OkVal v ls) _            lf rf = OkVal (lf.v) ls 
+   libBest' _            (OkVal w rs) lf rf = OkVal (rf.w) rs 
+   libBest' (Ok      ls) _            lf rf = OkVal lf ls           
+   libBest' _            (Ok      rs) lf rf = OkVal rf rs   
+   libBest' l@(Cost i ls ) r@(Cost j rs ) lf rf
+    | i =={-I-} j = Cost i (libBest' ls rs lf rf)
+    | i <{-I-} j  = Cost i (val lf ls)
+    | i >{-I-} j  = Cost j (val rf rs)
+   libBest' l@(Cost i ls)     _                 lf rf = Cost i (val lf ls)
+   libBest' _                 r@(Cost j rs)     lf rf = Cost j (val rf rs)
+   libBest' l@(NoMoreSteps v) _                 lf rf = NoMoreSteps (lf v)
+   libBest' _                 r@(NoMoreSteps w) lf rf = NoMoreSteps (rf w)
+   libBest' l                 r                 lf rf = libCorrect l r lf rf
+
+   libCorrect ls rs lf rf
+    =  let (Pairs  _ select) = traverse (traverse (Pairs 999{-I-} fst) (Pairs 0{-I-} fst) ls 4{-I-})  (Pairs 0{-I-} snd) rs 4{-I-} 
+           leftstart  = starting ls
+           rightstart = starting rs
+       in Best ls
+               (select (val lf (addexpecting rightstart ls), val rf (addexpecting leftstart rs)))
+               (leftstart `eor` rightstart)
+               rs
+
+   data Pairs = Pairs Int{-I-} (forall a. (a,a) -> a)
+   traverse b@(Pairs bv br) t@(Pairs tv tr) _                             0{-I-}  = if bv <{-I-} tv then b else t
+   traverse b@(Pairs bv br) t@(Pairs tv tr) (Ok            l)             n       = traverse b t l (n -{-I-} 1{-I-})
+   traverse b@(Pairs bv br) t@(Pairs tv tr) (OkVal  v      l)             n       = traverse b t l (n -{-I-} 1{-I-})
+   traverse b@(Pairs bv br) t@(Pairs tv tr) (Cost i   l)                  n       = if i +{-I-} tv >={-I-} bv then b else traverse b (Pairs (i +{-I-} tv) tr) l (n -{-I-} 1{-I-})
+   traverse b@(Pairs bv br) t@(Pairs tv tr) (Best l _ _ r)                n = traverse (traverse b t l n) t r n
+   traverse b@(Pairs bv br) t@(Pairs tv tr) (StRepair     i   msgs     r) n = if i +{-I-} tv >={-I-} bv then b else traverse b (Pairs (i +{-I-} tv) tr) r (n -{-I-} 1{-I-})
+   traverse b@(Pairs bv br) t@(Pairs tv tr) (NoMoreSteps _)               n = if bv <{-I-} tv then b else t
+
+
+
+
+
+   data AnaParser  state result s a
+    = AnaParser { pars :: ParsRec state result s a
+                , zerop :: Maybe (Bool, Either a (ParsRec state result s a))
+                , onep :: OneDescr state  result s a
+                } -- deriving Show
+   data OneDescr  state result s a
+    = OneDescr  { leng :: Nat
+                , firsts :: Exp s
+                , table :: [(SymbolR s, TableEntry state result s a)]
+                } -- deriving Show
+                
+   data TableEntry state result s a = TableEntry (ParsRec  state result s a) (Exp s -> ParsRec state result s a)
+
+
+
+
+
+   anaFail = AnaParser { pars    = libFail
+                       , zerop   = Nothing
+                       , onep    = noOneParser
+                       }
+   noOneParser = OneDescr Infinite (EOr []) []
+
+   pEmpty p zp = AnaParser { pars    = p
+                           , zerop   = Just zp
+                           , onep    = noOneParser
+                           }
+
+   anaSucceed  v = pEmpty (libSucceed v) (False, Left v)
+   anaLow      v = pEmpty (libSucceed v) (True,  Left v)
+   anaDynE     p = pEmpty p              (False, Right p)
+   anaDynL     p = pEmpty p              (True , Right p)
+   anaDynN  fi len range p = mkParser  Nothing (OneDescr len fi [(range, p)]) 
+
+   anaOr ld@(AnaParser _ zl ol)  rd@(AnaParser _ zr or)
+    = mkParser newZeroDescr newOneDescr
+      where newZeroDescr  = case zl of {Nothing -> zr
+                                       ;_       -> case zr of {Nothing -> zl
+                                                              ;_       -> usererror ("Two empty alternatives, where expecting"++show (firsts newOneDescr))
+                                       }                      }
+            newOneDescr   =  orOneOneDescr ol or False
+
+   {-# INLINE anaSeq #-}
+   anaSeq libdollar libseq comb (AnaParser  pl zl ol)  ~rd@(AnaParser pr zr or)
+    = case zl of
+      Just (b, zp ) -> let newZeroDescr = seqZeroZero zl zr   libdollar libseq comb
+                           newOneDescr = let newOneOne  = mapOnePars (   `libseq` pr) (const Infinite) ol
+                                             newZeroOne = case zp of
+                                                          Left  f -> mapOnePars (f `libdollar`   ) id or
+                                                          Right p -> mapOnePars (p `libseq`      ) id or
+                                         in orOneOneDescr newZeroOne newOneOne  b -- left one is shortest
+                       in mkParser newZeroDescr newOneDescr
+      _            ->  AnaParser  (pl `libseq` pr) Nothing  (mapOnePars (`libseq` pr) (`nat_add` (pLength rd)) ol)
+
+   seqZeroZero Nothing             _                    _          _      _   = Nothing
+   seqZeroZero _                   Nothing              _          _      _   = Nothing 
+   seqZeroZero (Just (llow, left)) (Just (rlow, right))  libdollar libseq comb
+       = Just      ( llow || rlow
+                  , case left of
+                    Left  lv  -> case right of
+                                 Left  rv -> Left (comb lv rv)
+                                 Right rp -> Right (lv `libdollar` rp)
+                    Right lp  -> case right of
+                                 Left  rv  -> Right (lp `libseq` libSucceed rv)
+                                 Right rp  -> Right (lp `libseq` rp)
+                  )
+
+   orOneOneDescr ~(OneDescr ll fl tl) ~(OneDescr lr fr tr)  b
+                     = let newfirsts       = (fl `eor` fr) 
+                           (newlength, maybeswap) = ll `nat_min` lr
+                           (tla, tra)      = if b then (tl, tr) else maybeswap (tl, tr)
+                           keystr          = map fst tra
+                           lefttab         = if b then [r | r@(k,_) <- tla, k `notElem` keystr] else tla
+                       in OneDescr newlength (fl `eor` fr) (lefttab ++ tra)
+
+   anaCostRange _        _     EmptyR = anaFail
+   anaCostRange ins_cost ins_sym range
+     = mkParser Nothing ( OneDescr (Succ Zero) (ESym range) [(range, TableEntry  libAccept 
+                                                                                 (libInsert ins_cost ins_sym)
+                                                            )]) 
+
+   anaCostSym   i ins sym = pCostRange i ins (Range sym sym)
+
+   pLength (AnaParser _ (Just _)  _ ) = Zero
+   pLength (AnaParser _  Nothing  od) = leng od
+
+   anaGetFirsts (AnaParser  p z od) = firsts od
+
+   anaSetFirsts newexp (AnaParser  _ zd od)
+    = mkParser zd (od{firsts = newexp })
+
+
+
+
+
+   mapOnePars fp fl ~(OneDescr l fi t) = OneDescr (fl l) fi [ (k, TableEntry (fp p) (fp.corr))
+                                                            | (k, TableEntry     p      corr ) <- t
+                                                            ]
+
+
+
+
+
+   mkParser  zd ~descr@(OneDescr _ firsts tab) -- pattern matching should be lazy for lazy computation of length for empty parsers
+    = let parstab    = if null tab then fatal 726 "parstab undefined" else
+                       foldr1 mergeTables  [[(k, p)] | (k, TableEntry p _) <- tab]
+          mkactualparser getp 
+            = let find       = case  parstab of
+                               [(ran,  pp)]     -> let comp = symInRange ran
+                                                       pars = Just (getp pp) 
+                                                   in \ s -> if comp s then pars else Nothing
+                               _           -> btLookup.tab2tree $  [(k,Just (getp pr) ) | (k, pr) <- parstab]
+                  zerop      = getp (case zd of
+                                    Nothing           -> libFail
+                                    Just (_, Left v)  -> libSucceed v
+                                    Just (_, Right p) -> p
+                                    ) 
+                  insertsyms = if null tab then fatal 739 "insertsyms undefined" else
+                               foldr1 lib_correct [   getp (pr firsts) | (_ , TableEntry _ pr) <- tab    ]
+                  correct k inp
+                    = case splitState inp of
+                          ({-L-} s, ss {-R-}) -> libCorrect (StRepair(deleteCost s) (Msg  ("deleting symbol " ++ show s
+                                                                                          , getPosition inp
+                                                                                          , firsts
+                                                                                    )     ) (result k ss)) 
+                                                            (insertsyms k inp) id id
+                  result = if null tab then zerop
+                           else case zd of
+                           Nothing        ->(\k inp -> case splitStateE inp of
+                                                       Left' s ss -> case find s of 
+                                                                     Just p  ->  p k inp
+                                                                     Nothing -> correct k inp
+                                                       Right' _   -> insertsyms   k inp)
+                           Just (True, _) ->(\k inp -> case splitStateE inp of
+                                                       Left' s ss -> case find s of 
+                                                                     Just p  -> p k inp 
+                                                                     Nothing -> let r = zerop k inp 
+                                                                                in if hasSuccess r then r else libCorrect r (correct k inp) id id
+                                                       Right' _   -> zerop k inp)
+                           Just (False, _) ->(\k inp -> case splitStateE inp of
+                                                       Left' s ss -> case find s of 
+                                                                     Just p  -> p k inp `libBest` zerop k inp
+                                                                     Nothing -> let r = zerop k inp 
+                                                                                in if hasSuccess r then r else libCorrect r (correct k inp) id id
+                                                       Right' _   -> zerop k inp)
+              in result
+          res    = PR (P ( \ acc ->  mkactualparser (\ (PR (P p, _)) -> p acc))
+                      ,R (           mkactualparser (\ (PR (_, R p)) -> p    ))
+                      )            
+      in AnaParser res zd descr
+      
+   lib_correct p q k inp = libCorrect (p k inp) (q k inp) id id
+
+
+
+
+
+   data Nat = Zero
+            | Succ Nat
+            | Infinite
+            deriving (Eq, Show)
+
+   nat_le Zero      _        = True
+   nat_le _         Zero     = False
+   nat_le Infinite  _        = False
+   nat_le _         Infinite = True
+   nat_le (Succ l) (Succ r) = nat_le l r
+
+   nat_min Infinite   r          = (r, swap) where swap (a,b) = (b,a)
+   nat_min l          Infinite   = (l, id)
+   nat_min Zero       _          = (Zero, id)
+   nat_min _          Zero       = (Zero, swap) where swap (a,b) = (b,a)
+   nat_min (Succ ll)  (Succ rr)  = let (v, fl) = ll `nat_min` rr in (Succ v, fl)
+
+   nat_add Infinite  _ = Infinite
+   nat_add Zero      r = r
+   nat_add (Succ l)  r = Succ (nat_add l r)
+
+
+
+
+
+   mergeTables l []  = l
+   mergeTables [] r  = r
+   mergeTables lss@(l@(le@(Range a b),ct ):ls) rss@(r@(re@(Range c d),ct'):rs)
+    = let ct'' =  ct `libOr` ct'
+      in  if      c<a then   mergeTables rss lss     -- swap
+          else if b<c then l:mergeTables ls  rss     -- disjoint case
+          else if a<c then (Range a (symBefore c),ct) :mergeTables ((Range c b,ct):ls)             rss
+          else if b<d then (Range a b,ct'')           :mergeTables ((Range (symAfter b) d,ct'):rs) ls
+          else if b>d then mergeTables rss lss
+                      else (le,ct'') : mergeTables ls rs-- equals
+
+
+
+
+
+   libMap ::    (forall r r'' . (b -> r -> r'') -> state s -> Result (a, r) s -> ( state s, Result  r'' s)) 
+             -> (forall r      .                   state s -> Result     r  s -> ( state s, Result  r   s))
+             -> ParsRec state result s a -> ParsRec state result s b
+   libMap f f' (PR (P p, R r))       = PR ( P(\acc -> let pp   = p (,)
+                                                          facc = f acc 
+                                                      in \ k instate  -> let inresult = pp k outstate
+                                                                             (outstate, outresult) = facc instate inresult
+                                                                         in outresult
+                                             )
+                                          , R(\ k instate  -> let inresult = r k outstate
+                                                                  (outstate, outresult) = f' instate inresult
+                                                              in outresult)
+                                          )
+
+   pMap ::    OutputState result =>
+                (forall r r'' . (b -> r -> r'') -> state s -> Result (a, r) s -> ( state s, Result r'' s)) 
+             -> (forall r     .                    state s -> Result     r  s -> ( state s, Result r   s))
+             ->  AnaParser state result s a -> AnaParser state result s b
+
+   pMap f f'  (AnaParser p z o) = AnaParser (libMap f f' p)
+                                             (case z of
+                                              Nothing     -> Nothing
+                                              Just (b, v) -> Just (b, case v of
+                                                                      Left w   -> Right (libMap f f' (libSucceed w))
+                                                                      Right pp -> Right (libMap f f' pp)))
+                                             (mapOnePars (libMap f f') id o)
+   libWrap ::    (forall r r'' .   (b -> r -> r'') 
+                                       -> state s 
+                                       -> Result (a, r) s 
+                                       -> (state s -> Result r s) 
+                                       -> (state s, Result r'' s, state s -> Result r s))
+              -> (forall r         .   state s 
+                                   -> Result r  s 
+                                   -> (state s -> Result r s) 
+                                   -> (state s, Result r s, state s -> Result r s)) 
+              -> ParsRec state result s a -> ParsRec state result s b
+   libWrap f f' (PR (P p, R r)) = PR ( P(\ acc -> let pp = p (,)
+                                                      facc = f acc
+                                                  in \ k instate  -> let (stl, ar, str2rr) = facc instate rl k
+                                                                         rl                = pp str2rr stl
+                                                                     in  ar
+                                        )
+                                     , R(\ k instate  -> let (stl, ar, str2rr) = f' instate rl k
+                                                             rl                = r str2rr stl
+                                                         in  ar)
+                                     )
+
+   pWrap ::    OutputState result 
+              => (forall r  r''.   (b -> r -> r'') 
+                                       -> state s 
+                                       -> Result (a, r) s 
+                                       -> (state s -> Result r s) 
+                                       -> (state s, Result r'' s, state s -> Result r s))
+              -> (forall r         .   state s 
+                                   -> Result r s 
+                                   -> (state s -> Result r s) 
+                                   -> (state s, Result r s, state s -> Result r s)) 
+              -> AnaParser state result s a -> AnaParser state result s b
+
+   pWrap f f'  (AnaParser p z o) = AnaParser (libWrap f f' p)
+                                             (case z of
+                                              Nothing     -> Nothing
+                                              Just (b, v) -> Just (b, case v of
+                                                                      Left w   -> Right (libWrap f f' (libSucceed w))
+                                                                      Right pp -> Right (libWrap f f' pp)))
+                                             (mapOnePars (libWrap f f') id o)
+
+
+
+
+
+   data  SymbolR s  =  Range s s | EmptyR deriving (Eq,Ord)
+
+   instance Symbol s => Show (SymbolR s) where
+    show EmptyR      = "the empty range"
+    show (Range a b) = if a == b then show a else show a ++ ".." ++ show b
+
+   mk_range             l    r =  if l > r then EmptyR else Range l r
+
+   symInRange (Range l r) = if l == r then (l==)
+                                      else (\ s -> not (s < l || r < s ))
+
+   symRS (Range l r)
+     = if l == r then (compare l)
+       else (\ s -> if      s < l then GT
+                    else if s > r then LT
+                    else               EQ)
+
+   range `except` elems
+    = foldr removeelem [range] elems
+      where removeelem elem ranges = [r | ran <- ranges, r <- ran `minus` elem]
+            EmptyR          `minus` _    = []
+            ran@(Range l r) `minus` elem = if symInRange ran elem
+                                           then [mk_range l (symBefore elem), mk_range (symAfter elem) r]
+                                           else [ran]
+
+
+
+
+
+   usererror   m = fatal 917 $ "Your grammar contains a problem:\n" ++ m
+   systemerror modname m
+     = fatal 919 $ "I apologise: I made a mistake in my design. This should not have happened.\n" ++
+                   " Please report: " ++ modname ++": " ++ m ++ " to doaitse@cs.uu.nl\n"
+
+
+
+
+
+   newtype Perms p a = Perms (Maybe (p a), [Br p a])
+   data Br p a = forall b. Br (Perms p (b -> a)) (p b)
+
+   perms ~*~ p = perms `add` (getzerop p, getonep p)
+   f     ~$~ p = Perms (Just (pLow f), []) ~*~ p
+
+   add b2a@(Perms (eb2a, nb2a)) bp@(eb, nb)
+    =  let changing :: Sequence a => (b -> c) -> Perms a b -> Perms a c
+           f `changing` Perms (ep, np) = Perms (fmap (f <$>) ep, [Br ((f.) `changing` pp) p | Br pp p <- np])
+       in Perms
+         ( do { f <- eb2a
+              ; x <- eb
+              ; return (f <*>  x)
+              }
+         ,  (case nb of
+             Nothing     -> id
+             Just pb     -> (Br b2a  pb:)
+           )[ Br ((flip `changing` c) `add`  bp) d |  Br c d <- nb2a]
+         )
+
+   pPerms (Perms (empty,nonempty))
+    = foldl (<|>) (fromMaybe pFail empty) [ (flip ($)) <$> p <*> pPerms pp
+                                          | Br pp  p <- nonempty
+                                          ]
+
+   pPermsSep  = p2p (pSucceed ()) 
+
+   p2p fsep sep (Perms (mbempty, nonempties)) = foldr (<|>) empty (map pars nonempties)
+    where empty      = fromMaybe  pFail mbempty
+          pars (Br t p)  = flip ($) <$ fsep <*> p <*> p2p sep sep t
+
+
+
+
+
+   acceptsepsilon p       = case getzerop p of {Nothing -> False; _ -> True}
+
+   mnz p v
+      = if( acceptsepsilon p)
+        then   usererror ("You are calling a list based derived combinator with a parser that accepts the empty string.\n"
+                       ++
+                      "We cannot handle the resulting left recursive formulation (and it is ambiguous too).\n"++
+                      (case getfirsts p of
+                       ESeq []  ->  "There are no other alternatives for this parser"
+                       d        ->  "The other alternatives of this parser may start with:\n"++ show d
+                     ))
+        else v
+
+
+
+
+
+   a <..> b   = pRange a (Range a b)
+   (l,r,err) `pExcept` elems = let ranges = filter (/= EmptyR) (Range l r `except` elems)
+                               in if null ranges then pFail
+                                  else foldr (<|>) pFail (map (pRange err) ranges)
+
+   p `opt` v       = mnz p (p  <|> pLow v)   -- note that opt is greedy, if you do not want this
+                                                 -- use "... <|> pSucceed v"  instead
+                                                 -- p should not recognise the empty string
+
+
+
+
+
+   asList  exp = setfirsts (ESeq [EStr "(",  exp, EStr  " ...)*"])
+   asList1 exp = setfirsts (ESeq [EStr "(",  exp, EStr  " ...)+"])
+   asOpt   exp = setfirsts (ESeq [EStr "( ", exp, EStr  " ...)?"])
+   pa <+> pb       = (,) <$> pa <*> pb
+   p <**> q        = (\ x f -> f x) <$> p <*> q
+   f <$$> p        = pSucceed (flip f) <*> p
+   p <??> q        = p <**> (q `opt` id)
+   p <?>  str      = setfirsts  (EStr str) p
+   pPacked l r x   =   l *>  x <*   r
+
+
+
+
+
+   pFoldr_ng      alg@(op,e)     p = mnz p (asList (getfirsts p) pfm)
+                                     where pfm = (op <$> p <*> pfm)  <|> pSucceed e
+   pFoldr_gr      alg@(op,e)     p = mnz p (asList (getfirsts p) pfm)
+                                     where pfm = (op <$> p <*> pfm) `opt` e
+   pFoldr                          = pFoldr_gr
+
+   pFoldr1_gr     alg@(op,e)     p = asList1 (getfirsts p) (op <$> p <*> pFoldr_gr  alg p)
+   pFoldr1_ng     alg@(op,e)     p = asList1 (getfirsts p) (op <$> p <*> pFoldr_ng  alg p)
+   pFoldr1                         = pFoldr1_gr
+
+   pFoldrSep_gr   alg@(op,e) sep p = mnz p (asList (getfirsts p)((op <$> p <*> pFoldr_gr alg (sep *> p)) `opt` e ))
+   pFoldrSep_ng   alg@(op,e) sep p = mnz p (asList (getfirsts p)((op <$> p <*> pFoldr_ng alg (sep *> p))  <|>  pSucceed e))
+   pFoldrSep                       = pFoldrSep_gr
+
+   pFoldr1Sep_gr  alg@(op,e) sep p = if acceptsepsilon sep then mnz p pfm else pfm
+                                     where pfm = op <$> p <*> pFoldr_gr alg (sep *> p)
+   pFoldr1Sep_ng  alg@(op,e) sep p = if acceptsepsilon sep then mnz p pfm else pfm
+                                     where pfm = op <$> p <*> pFoldr_ng alg (sep *> p)
+   pFoldr1Sep                      = pFoldr1Sep_gr
+
+   list_alg = ((:), [])
+
+   pList_gr        = pFoldr_gr     list_alg  
+   pList_ng        = pFoldr_ng     list_alg  
+   pList           = pList_gr
+
+   pList1_gr       = pFoldr1_gr    list_alg  
+   pList1_ng       = pFoldr1_ng    list_alg  
+   pList1          = pList1_gr               
+
+   pListSep_gr     = pFoldrSep_gr  list_alg
+   pListSep_ng     = pFoldrSep_ng  list_alg
+   pListSep        = pListSep_gr
+
+   pList1Sep_gr    = pFoldr1Sep_gr list_alg
+   pList1Sep_ng    = pFoldr1Sep_ng list_alg
+   pList1Sep       = pList1Sep_gr
+
+   pChainr_gr op x    =  if acceptsepsilon op then mnz x r else r
+                      where r = x <??> (flip <$> op <*> r)
+   pChainr_ng op x    =  if acceptsepsilon op then mnz x r else r
+                      where r = x <**> ((flip <$> op <*> r)  <|> pSucceed id)
+   pChainr            = pChainr_gr
+
+   pChainl_gr op x    =  if acceptsepsilon op then mnz x r else r
+                         where
+                          r      = (f <$> x <*> pList_gr (flip <$> op <*> x) )
+                          f x [] = x
+                          f x (func:rest) = f (func x) rest
+
+   pChainl_ng op x    =  if acceptsepsilon op then mnz x r else r
+                      where
+                       r      = (f <$> x <*> pList_ng (flip <$> op <*> x) )
+                       f x [] = x
+                       f x (func:rest) = f (func x) rest
+   pChainl            = pChainl_gr
+
+   pAny  f l = if null l then usererror "pAny: argument may not be empty list" else foldr1 (<|>) (map f l)
+   pAnySym   = pAny pSym -- used to be called pAnySym
+
+
+
+
+
+
+   (pe, pp, punp) <||> (qe, qp, qunp)
+    =( (pe, qe)
+     , (\f (pv, qv) -> (f pv, qv)) <$> pp
+                 <|>
+       (\f (pv, qv) -> (pv, f qv)) <$> qp
+     , \f (x, y) -> qunp (punp f x) y
+     )
+
+   sem `pMerged` (units, alts, unp)
+    = let pres = alts <*> pres `opt` units
+      in unp sem <$> pres
+
+   usealg (op, e) p = (e, op <$> p, id)
+   list_of = usealg list_alg
+
+   pToks []     = pSucceed []
+   pToks (a:as) = (:) <$> pSym a <*> pToks as
+
+   pLocate = pAny pToks
+
+
+
+
+
+   data BinSearchTree a b
+    = Node (BinSearchTree a b) (a, b) (BinSearchTree a b)
+    | Nil
+
+   tab2tree tab = tree
+    where
+     (tree,[]) = sl2bst (length tab) [ (symRS k, v) | (k, v) <- tab]
+     sl2bst 0 list     = (Nil   , list)
+     sl2bst n list
+      = let
+         ll = (n - 1) `div` 2 ; rl = n - 1 - ll
+         (lt,a:list1) = sl2bst ll list
+         (rt,  list2) = sl2bst rl list1
+        in (Node lt a rt, list2)
+
+
+
+   btLookup
+    = find_in
+      where find_in  Nil = \i -> Nothing
+            find_in (Node Nil (k,v) Nil)
+             = (\i -> case k i of    { LT -> Nothing
+                                     ; EQ ->  v
+                                     ; GT -> Nothing
+                                     })
+            find_in (Node Nil (k,v) right)
+             = (\i -> case k i of    { LT -> findright i
+                                     ; EQ ->  v
+                                     ; GT -> Nothing
+                                     })
+               where findright = find_in right
+            find_in (Node left (k,v) Nil)
+             = (\i -> case k i of    { LT -> Nothing
+                                     ; EQ -> v
+                                     ; GT -> findleft  i
+                                     })
+               where findleft  = find_in left
+            find_in (Node left (k,v) right)
+             = (\i -> case k i of    { LT -> findright i
+                                     ; EQ -> v
+                                     ; GT -> findleft  i
+                                     })
+               where findleft  = find_in left
+                     findright = find_in right
+ src/lib/DatabaseDesign/Ampersand/Input/ADL1/UU_Scanner.hs view
@@ -0,0 +1,363 @@+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
+module DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner where
+
+   import Data.Char
+   import Data.List
+   import Data.Maybe
+   import DatabaseDesign.Ampersand.Input.ADL1.UU_BinaryTrees(tab2tree,btLocateIn)
+   import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing(Symbol(..),IsParser,pSym,(<$>),pListSep,pPacked)
+
+   data TokenType
+     = TkSymbol
+     | TkVarid
+     | TkConid
+     | TkKeyword
+     | TkOp
+     | TkString
+     | TkExpl
+     | TkAtom
+     | TkChar
+     | TkInteger8
+     | TkInteger10
+     | TkInteger16
+     | TkTextnm
+     | TkTextln
+     | TkSpace
+     | TkError
+     deriving (Eq, Ord)
+
+   type Line = Int
+   type Column = Int
+
+   data Pos = Pos{line:: !Line, column:: !Column} deriving (Eq, Ord)
+   type Filename   = String
+
+   data Token = Tok { tp :: TokenType
+                    , val1 :: String
+                    , val2 :: String
+                    , pos :: !Pos
+                    , file :: !Filename
+                    }
+
+   instance Eq Token where
+     --(Tok TkOp       ""      l _ _) ==  (Tok TkOp       ""      r _ _) =  l == r
+     --(Tok TkOp       ""      l _ _) ==  (Tok TkOp       r       _ _ _) =  l == r
+     --(Tok TkOp       l       _ _ _) ==  (Tok TkOp       ""      r _ _) =  l == r
+     (Tok ttypel     stringl _ _ _) ==  (Tok ttyper     stringr _ _ _) =  ttypel == ttyper && stringl == stringr
+
+   instance   Ord Token where
+     compare x y | x==y      = EQ
+                 | x<=y      = LT
+                 | otherwise = GT
+     (Tok ttypel     stringl _ _ _ ) <= (Tok ttyper    stringr _ _  _ )
+         =     ttypel <  ttyper
+           || (ttypel == ttyper && stringl <= stringr)
+
+   maybeshow :: Pos -> Filename -> String
+   maybeshow (Pos 0 0) fn =  ""
+   maybeshow (Pos l c) fn =  " at line " ++ show l
+                          ++ ", column " ++ show c
+                          ++ " of file " ++ show fn
+
+   initPos :: Pos
+   initPos = Pos 1 1
+
+   noPos :: Pos
+   noPos = Pos 0 0
+
+   advl ::  Line -> Pos ->Pos
+   advl i (Pos l c) = Pos (l+i) 1
+
+   advc :: Column -> Pos ->  Pos
+   advc i (Pos l c) = Pos l (c+i)
+
+   adv :: Pos -> Char -> Pos
+   adv pos c = case c of
+     '\t' -> advc (tabWidth (column pos)) pos
+     '\n' -> advl 1 pos
+     _    -> advc 1 pos
+
+   tabWidth :: Column -> Int
+   tabWidth c = 8 - ((c-1) `mod` 8)
+
+   instance Show Token where
+     showsPrec _ token
+       = showString
+          (case token of
+           (Tok TkSymbol    _  s2 i fn)  -> "symbol "                ++ s2         ++ maybeshow i fn
+           (Tok TkOp        _  s2 i fn)  -> "operator "              ++ s2         ++ maybeshow i fn
+           (Tok TkKeyword   _  s2 i fn)  ->                        show s2         ++ maybeshow i fn
+           (Tok TkString    _  s2 i fn)  -> "string \""              ++ s2 ++ "\"" ++ maybeshow i fn
+           (Tok TkExpl      _  s2 i fn)  -> "explanation {+"         ++ s2 ++ "-}" ++ maybeshow i fn
+           (Tok TkAtom      _  s2 i fn)  -> "atom '"                 ++ s2 ++ "'"  ++ maybeshow i fn
+           (Tok TkChar      _  s2 i fn)  -> "character '"            ++ s2 ++ "'"  ++ maybeshow i fn
+           (Tok TkInteger8  _  s2 i fn)  -> "octal integer "         ++ s2         ++ maybeshow i fn
+           (Tok TkInteger10 _  s2 i fn)  -> "decimal Integer "       ++ s2         ++ maybeshow i fn
+           (Tok TkInteger16 _  s2 i fn)  -> "hexadecimal integer "   ++ s2         ++ maybeshow i fn
+           (Tok TkVarid     _  s2 i fn)  -> "lower case identifier " ++ s2         ++ maybeshow i fn
+           (Tok TkConid     _  s2 i fn)  -> "upper case identifier " ++ s2         ++ maybeshow i fn
+           (Tok TkTextnm    _  s2 i fn)  -> "text name "             ++ s2         ++ maybeshow i fn
+           (Tok TkTextln    _  s2 i fn)  -> "text line "             ++ s2         ++ maybeshow i fn
+           (Tok TkSpace     _  s2 i fn)  -> "spaces "                              ++ maybeshow i fn
+           (Tok TkError     _  s2 i fn)  -> "error in scanner: "     ++ s2         ++ maybeshow i fn
+          )
+
+   instance  Symbol Token where
+     deleteCost (Tok TkKeyword _ _ _ _) = 10
+     deleteCost _                       = 5
+
+   keyToken,token :: TokenType -> String -> Pos -> Filename -> Token
+   keyToken tp key  = Tok tp key key
+   token  tp  = Tok tp ""  
+
+   errToken :: String -> Pos -> Filename -> Token
+   errToken = token TkError
+
+   skipline s = let (_,rest) = span (/='\n') s
+                in  rest
+
+   scan :: [String] -> [String] -> String -> String -> String -> Pos -> String -> [Token]
+   scan keywordstxt keywordsops specchars opchars fn pos input
+     = doScan pos input
+
+    where
+      locatein :: Ord a => [a] -> a -> Bool
+      locatein es = isJust . btLocateIn compare (tab2tree (sort es))
+      iskw     = locatein keywordstxt
+      isop     = locatein keywordsops
+      isSymbol = locatein specchars
+      isOpsym  = locatein opchars
+
+      isIdStart c = isLower c || c == '_'
+
+      isIdChar c =  isAlphaNum c
+--               || c == '\''   -- character literals are not used in Ampersand. Since this scanner was used for Haskell-type languages, this alternative is commented out...
+                 || c == '_'
+
+      scanIdent p s = let (name,rest) = span isIdChar s
+                      in (name,advc (length name) p,rest)
+      doScan p [] = []
+      doScan p (c:s)        | isSpace c = let (sp,next) = span isSpace s
+                                          in  doScan (foldl adv p (c:sp)) next
+
+      doScan p ('-':'-':s)  = doScan p (dropWhile (/= '\n') s)
+      doScan p ('-':'+':s)  = token TkExpl (dropWhile isSpace (takeWhile (/= '\n') s)) p fn
+                              : doScan p (dropWhile (/= '\n') s)
+      doScan p ('{':'-':s)  = lexNest fn doScan (advc 2 p) s
+      doScan p ('{':'+':s)  = lexExpl fn doScan (advc 2 p) s
+      doScan p ('"':ss)
+        = let (s,swidth,rest) = scanString ss
+          in if null rest || head rest /= '"'
+                then errToken "Unterminated string literal" p fn : doScan (advc swidth p) rest
+                else token TkString s p fn : doScan (advc (swidth+2) p) (tail rest)
+{- In Ampersand, atoms may be promoted to singleton relations by single-quoting them. For this purpose, we treat
+   single quotes exactly as the double quote for strings. That substitutes the scanner code for character literals. -}
+      doScan p ('\'':ss)
+        = let (s,swidth,rest) = scanAtom ss
+          in if null rest || head rest /= '\''
+                then errToken "Unterminated atom literal" p fn : doScan (advc swidth p) rest
+                else token TkAtom s p fn : doScan (advc (swidth+2) p) (tail rest)
+
+{- character literals are not used in Ampersand.  doScan p ('\'':ss) is commented out to make room for singleton atoms.
+      doScan p ('\'':ss)
+        = let (mc,cwidth,rest) = scanChar ss
+          in case mc of
+               Nothing -> errToken "Error in character literal" p fn : doScan (advc cwidth p) rest
+               Just c  -> if null rest || head rest /= '\''
+                             then errToken "Unterminated character literal" p fn : doScan (advc (cwidth+1) p) rest
+                             else token TkChar [c] p fn : doScan (advc (cwidth+2) p) (tail rest)
+-}
+
+      -- In Haskell infix identifiers consist of three separate tokens(two backquotes + identifier)
+      doScan p ('`':ss)
+        = case ss of
+            []    -> [errToken "Unterminated infix identifier" p fn]
+            (c:s) -> let res | isIdStart c || isUpper c =
+                                      let (name,p1,rest) = scanIdent (advc 2 p) s
+                                          ident = c:name
+                                          tokens | null rest ||
+                                                   head rest /= '`' = errToken "Unterminated infix identifier" p fn
+                                                                    : doScan p1 rest
+                                                 | iskw ident       = errToken ("Keyword used as infix identifier: " ++ ident) p fn
+                                                                    : doScan (advc 1 p1) (tail rest)
+                                                 | otherwise        = token TkOp ident p fn
+                                                                    : doScan (advc 1 p1) (tail rest)
+                                      in tokens
+                             | otherwise = errToken ("Unexpected character in infix identifier: " ++ show c) p fn
+                                         : doScan (adv p c) s
+                     in res
+      doScan p cs@(c:s)
+        | isSymbol c = keyToken TkSymbol [c] p fn
+                     : doScan(advc 1 p) s
+        | isIdStart c || isUpper c
+            = let (name', p', s')    = scanIdent (advc 1 p) s
+                  name               = c:name'
+                  tok    | iskw name = keyToken TkKeyword name p fn
+                         | null name' && isSymbol c
+                                     = keyToken TkSymbol [c] p fn
+                         | otherwise = token (if isIdStart c then TkVarid else TkConid) name p fn
+              in tok :  doScan p' s'
+        | isOpsym c = let (name, s') = getOp cs   -- was:      span isOpsym cs
+                          tok | isop name = keyToken TkKeyword name p fn
+                              | otherwise = keyToken TkOp name p fn
+                      in tok : doScan (foldl adv p name) s'
+        | isDigit c = let (tktype,number,width,s') = getNumber cs
+                      in  token tktype number p fn : doScan (advc width p) s'
+        | otherwise = errToken ("Unexpected character " ++ show c) p fn
+                    : doScan (adv p c) s
+
+      getOp cs -- the longest prefix of cs occurring in keywordsops
+       = f keywordsops cs ""
+         where
+          f ops (e:s) op = if null [s | o:s<-ops, e==o] then (op,e:s) --was: f ops (e:s) op = if and (map null ops) then (op,e:s) --b.joosten
+                           else f [s | o:s<-ops, e==o] s (op++[e])
+          f [] es op     = ("",cs)
+          f ops [] op    = (op,[])
+
+
+
+   lexNest fn cont pos inp = lexNest' cont pos inp
+    where lexNest' c p ('-':'}':s) = c (advc 2 p) s
+          lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s
+          lexNest' c p (x:s)       = lexNest' c (adv p x) s
+          lexNest' _ _ []          = [ errToken "Unterminated nested comment" pos fn ]
+
+   lexExpl fn cont pos inp = lexExpl' "" cont pos inp
+    where lexExpl' str c p ('-':'}':s) = token TkExpl str p fn: c (advc 2 p) s
+          lexExpl' str c p ('{':'-':s) = lexNest fn (lexExpl' str c) (advc 2 p) s
+          lexExpl' str c p ('-':'-':s) = lexExpl' str c  p (dropWhile (/= '\n') s)
+          lexExpl' str c p (x:s)       = lexExpl' (str++[x]) c (adv p x) s
+          lexExpl' _ _ _ []            = [ errToken "Unterminated EXPLAIN section" pos fn ]
+
+   scanString []            = ("",0,[])
+   scanString ('\\':'&':xs) = let (str,w,r) = scanString xs
+                              in (str,w+2,r)
+   scanString ('\'':xs)     = let (str,w,r) = scanString xs
+                              in ('\'': str,w+1,r)
+   scanString xs = let (ch,cw,cr) = getchar xs
+                       (str,w,r)  = scanString cr
+--                       str' = maybe "" (:str) ch
+                   in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch
+
+   scanAtom []              = ("",0,[])
+   scanAtom ('\\':'&':xs)   = let (str,w,r) = scanAtom xs
+                              in (str,w+2,r)
+   scanAtom ('"':xs)        = let (str,w,r) = scanAtom xs
+                              in ('"': str,w+1,r)
+   scanAtom xs   = let (ch,cw,cr) = getchar xs
+                       (str,w,r)  = scanAtom cr
+--                       str' = maybe "" (:str) ch
+                   in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch
+
+   scanChar ('"' :xs) = (Just '"',1,xs)
+   scanChar xs        = getchar xs
+
+   getchar []          = (Nothing,0,[])
+   getchar s@('\n':_ ) = (Nothing,0,s )
+   getchar s@('\t':_ ) = (Nothing,0,s)
+   getchar s@('\'':_ ) = (Nothing,0,s)
+   getchar s@('"' :_ ) = (Nothing,0,s)
+   getchar   ('\\':xs) = let (c,l,r) = getEscChar xs
+                         in (c,l+1,r)
+   getchar (x:xs)      = (Just x,1,xs)
+
+   getEscChar [] = (Nothing,0,[])
+   getEscChar s@(x:xs) | isDigit x = let (tp,n,len,rest) = getNumber s
+                                         val = case tp of
+                                                 TkInteger8  -> readn 8  n
+                                                 TkInteger16 -> readn 16 n
+                                                 TkInteger10 -> readn 10 n
+                                     in  if val >= 0 && val <= 255
+                                            then (Just (chr val),len, rest)
+                                            else (Nothing,1,rest)
+                       | otherwise = case x `lookup` cntrChars of
+                                    Nothing -> (Nothing,0,s)
+                                    Just c  -> (Just c,1,xs)
+     where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t')
+                       ,('v','\v'),('\\','\\'),('"','\"')]
+-- character literals are not used in Ampersand. Since this scanner was used for Haskell-type languages, ('\'','\'') has been removed from cntrChars...
+
+   readn base = foldl (\r x  -> value x + base * r) 0
+
+   getNumber cs@(c:s)
+     | c /= '0'         = num10
+     | null s           = const0
+     | hs `elem` "xX"   = num16
+     | hs `elem` "oO"   = num8
+     | otherwise        = num10
+     where (hs:ts) = s
+           const0 = (TkInteger10, "0",1,s)
+           num10  = let (n,r) = span isDigit cs
+                    in (TkInteger10,n,length n,r)
+           num16   = readNum isHexaDigit  ts TkInteger16
+           num8    = readNum isOctalDigit ts TkInteger8
+           readNum p ts tk
+             = let nrs@(n,rs) = span p ts
+               in  if null n then const0
+                             else (tk         , n, 2+length n,rs)
+
+   isHexaDigit  d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f')
+   isOctalDigit d = d >= '0' && d <= '7'
+
+   value c | isDigit c = ord c - ord '0'
+           | isUpper c = ord c - ord 'A' + 10
+           | isLower c = ord c - ord 'a' + 10
+
+
+
+
+
+   get_tok_val (Tok _ _ s _ _) = s
+
+   gsym :: IsParser p Token => TokenType -> String -> String -> p String
+   gsym kind val val2 = get_tok_val <$> pSym (Tok kind val val2 noPos "")
+   pString, pExpl, pAtom, pChar, pInteger8, pInteger10, pInteger16, pVarid, pConid,
+     pTextnm, pTextln, pInteger :: IsParser p Token => p String
+   pOper name     =   gsym TkOp        name      name
+   pKey  keyword  =   gsym TkKeyword   keyword   keyword
+   pSpec s        =   gsym TkSymbol    [s]       [s]
+
+   pString        =   gsym TkString    ""        ""
+   pExpl          =   gsym TkExpl      ""        ""
+   pAtom          =   gsym TkAtom      ""        ""
+   pChar          =   gsym TkChar      ""        "\NUL"
+   pInteger8      =   gsym TkInteger8  ""        "1"
+   pInteger10     =   gsym TkInteger10 ""        "1"
+   pInteger16     =   gsym TkInteger16 ""        "1"
+   pVarid         =   gsym TkVarid     ""        "?lc?"
+   pConid         =   gsym TkConid     ""        "?uc?"
+   pTextnm        =   gsym TkTextnm    ""        ""
+   pTextln        =   gsym TkTextln    ""        ""
+
+   pInteger       =   pInteger10
+
+   pComma, pSemi, pOParen, pCParen, pOBrack, pCBrack, pOCurly, pCCurly :: IsParser p Token => p String
+   pComma  = pSpec ','
+   pSemi   = pSpec ';'
+   pOParen = pSpec '('
+   pCParen = pSpec ')'
+   pOBrack = pSpec '['
+   pCBrack = pSpec ']'
+   pOCurly = pSpec '{'
+   pCCurly = pSpec '}'
+
+   pCommas ::  IsParser p Token => p a -> p [a]
+   pSemics ::  IsParser p Token => p a -> p [a]
+   pParens ::  IsParser p Token => p a -> p a
+   pBracks ::  IsParser p Token => p a -> p a
+   pCurly ::  IsParser p Token => p a -> p a
+
+   pCommas  = pListSep pComma
+   pSemics  = pListSep pSemi
+   pParens  = pPacked pOParen pCParen
+   pBracks  = pPacked pOBrack pCBrack
+   pCurly   = pPacked pOCurly pCCurly
+
+   pParens_pCommas :: IsParser p Token => p a -> p [a]
+   pBracks_pCommas :: IsParser p Token => p a -> p [a]
+   pCurly_pSemics :: IsParser p Token => p a -> p [a]
+
+   pParens_pCommas = pParens.pCommas
+   pBracks_pCommas = pBracks.pCommas
+   pCurly_pSemics  = pCurly .pSemics
+
+ src/lib/DatabaseDesign/Ampersand/Input/Parsing.hs view
@@ -0,0 +1,217 @@+{-# OPTIONS_GHC  -XScopedTypeVariables #-}
+module DatabaseDesign.Ampersand.Input.Parsing ( parseContext
+                                        , parseADL1pExpr
+                                        , ParseError)
+where
+
+import Control.Monad
+import Data.List
+import Data.Char
+import System.Directory
+import System.FilePath
+import DatabaseDesign.Ampersand.Input.ADL1.Parser (pContext,pPopulations,pTerm,keywordstxt, keywordsops, specialchars, opchars)
+import DatabaseDesign.Ampersand.Misc
+import DatabaseDesign.Ampersand.Basics
+import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner -- (scan,initPos)
+import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing -- (getMsgs,parse,evalSteps,parseIO)
+import DatabaseDesign.Ampersand.ADL1
+import Control.Exception
+import Paths_ampersand
+
+type ParseError = Message Token
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Input.Parsing"
+
+-- | The parser currently needs to be monadic, because there are multiple versions of the Ampersand language supported. Each parser
+--   currently throws errors on systemerror level. They can only be 'catch'ed in a monad.
+--   This parser is for parsing of a Context
+parseContext :: Options                          -- ^ flags to be taken into account
+             -> FilePath                         -- ^ the full path to the file to parse 
+             -> IO (Either ParseError P_Context) -- ^ The IO monad with the parse tree. 
+parseContext flags file 
+             = do { verboseLn flags $ "Parsing with "++show (parserVersion flags)++"..."
+                  ; rapRes <- if includeRap flags
+                              then do dataDir <- getDataDir
+                                      let rapFile = dataDir </> "AmpersandData" </> "RepoRap" </> "RAP.adl"
+                                      exists <- doesFileExist rapFile
+                                      when (not exists) (fatal 39 $ "RAP file isn't installed properly. RAP.adl expected at:"
+                                                                  ++"\n  "++show rapFile
+                                                                  ++"\n  (You might want to reinstall ampersand...)") 
+                                      parseADL flags rapFile
+                              else return (Right emptyContext)
+                  ; (case rapRes of
+                      Left err -> do verboseLn flags "Parsing of RAP failed"
+                                     return rapRes
+                      Right rapCtx 
+                               -> do eRes   <- parseADL flags file
+                                     case eRes of  
+                                       Right ctx  -> verboseLn flags "Parsing successful"
+                                                  >> return (Right (mergeContexts ctx rapCtx))
+                                       Left err -> verboseLn flags "Parsing failed"
+                                                >> return eRes
+                    )
+                  }
+                  
+                                             
+-- | Parse isolated ADL1 expression strings
+parseADL1pExpr :: String -> String -> Either String (Term TermPrim)
+parseADL1pExpr pexprstr fn = parseExpr Current pexprstr fn
+
+-- | Parse isolated ADL1 expression strings
+parseExpr :: ParserVersion     -- ^ The specific version of the parser to be used
+          -> String            -- ^ The string to be parsed
+          -> String            -- ^ The name of the file (used for error messages)
+          -> Either String (Term TermPrim)  -- ^ The result: Either an error message,  or a good result 
+parseExpr pv str fn =
+    case runParser pv pTerm fn str of
+      Right result -> Right result
+      Left  msg    -> Left $ "Parse errors for "++show pv++":\n"++show msg
+
+
+
+parseADL :: Options
+         -> FilePath      -- ^ The name of the .adl file
+         -> IO (Either ParseError P_Context) -- ^ The result: Either some errors, or the parsetree.
+parseADL flags file =
+ do { verboseLn flags $ "Files read:"
+    ; (result, parsedFiles) <- readAndParseFile flags 0 [] Nothing "" file
+    ; verboseLn flags $ "\n"
+    ; return result
+    }
+
+-- parse the input file and read and parse the imported files
+-- The alreadyParsed parameter keeps track of filenames that have been parsed already, which are ignored when included again.
+-- Hence, include cycles do not cause an error.
+-- We don't distinguish between "INCLUDE SomeADL" and "INCLUDE SoMeAdL" to prevent errors on case-insensitive file systems.
+-- (on a case-sensitive file system you do need to keep your includes with correct capitalization though)
+
+readAndParseFile :: Options -> Int -> [String] -> Maybe String -> String -> String ->
+                    IO (Either ParseError P_Context, [String])
+readAndParseFile flags depth alreadyParsed mIncluderFilepath fileDir relativeFilepath =
+ catch myMonad myHandler
+   where 
+     myMonad =
+       do { canonicFilepath <- fmap (map toUpper) $ canonicalizePath filepath
+            -- Legacy parser has no includes, so no need to print here
+      
+          ; if canonicFilepath `elem` alreadyParsed 
+            then do { verboseLn flags $ replicate (3*depth) ' ' ++ "(" ++ filepath ++ ")"
+                    ; return (Right emptyContext, alreadyParsed) -- returning an empty context is easier than a maybe (leads to some plumbing in readAndParseIncludeFiles)
+                    } 
+            else do { fileContents <- DatabaseDesign.Ampersand.Basics.readFile filepath
+                    ; verboseLn flags $ replicate (3*depth) ' ' ++ filepath
+                    ; parseFileContents flags (depth+1) (canonicFilepath:alreadyParsed)
+                                        fileContents newFileDir newFilename     
+                    }
+          }
+     myHandler :: IOException ->
+                  IO (Either ParseError P_Context, [String])
+     myHandler =   
+             (\exc -> do { error $ case mIncluderFilepath of
+                                 Nothing -> 
+                                   "\n\nError: cannot read ADL file " ++ show filepath
+                                 Just includerFilepath ->
+                                   "\n\nError: cannot read include file " ++ show filepath ++ 
+                                   ", included by " ++ show includerFilepath})
+     filepath = combine fileDir relativeFilepath
+     newFileDir = let dir = takeDirectory filepath in if dir == "." then "" else dir
+     newFilename = takeFileName filepath
+
+parseFileContents :: Options  -- ^ command-line options 
+                  -> Int      -- ^ The include depth
+                  -> [String] -- ^ Already parsed files (canonicalized) 
+                  -> String   -- ^ The string to be parsed
+                  -> String   -- ^ The path to the .adl file 
+                  -> String   -- ^ The name of the .adl file
+                  -> IO (Either ParseError P_Context, [String]) -- ^ The result: The updated already-parsed contexts and Either some errors, or the parsetree.
+parseFileContents flags depth alreadyParsed fileContents fileDir filename =
+  do { let filepath = combine fileDir filename
+     ; case parseSingleADL (parserVersion flags) fileContents filepath of
+           Left err -> return (Left err, alreadyParsed)
+           Right (parsedContext, includeFilenames) ->
+             do { (includeParseResults, alreadyParsed') <-
+                     readAndParseIncludeFiles flags alreadyParsed depth (Just $ combine fileDir filename) fileDir includeFilenames
+                ; return ( case includeParseResults of
+                             Left err              -> Left err
+                             Right includeContexts -> Right $ foldl mergeContexts parsedContext includeContexts
+                         , alreadyParsed' )             
+                }     
+    }
+
+readAndParseIncludeFiles :: Options -> [String] -> Int -> Maybe String -> String -> [String] ->
+                            IO (Either ParseError [P_Context], [String])
+readAndParseIncludeFiles flags alreadyParsed depth mIncluderFilepath fileDir [] = return (Right [], alreadyParsed)
+readAndParseIncludeFiles flags alreadyParsed depth mIncluderFilepath fileDir (relativeFilepath:relativeFilepaths) = 
+ do { (result, alreadyParsed') <- readAndParseFile flags depth alreadyParsed mIncluderFilepath fileDir relativeFilepath
+    ; case result of                               -- Include is only implemented in Current parser
+        Left err -> return (Left err, alreadyParsed')
+        Right context ->
+         do { (results, alreadyParsed'') <- readAndParseIncludeFiles flags alreadyParsed' depth mIncluderFilepath fileDir relativeFilepaths
+            ; case results of
+                Left err -> return (Left err, alreadyParsed'')
+                Right contexts -> return (Right $ context : contexts, alreadyParsed'') 
+            }
+    }
+ 
+emptyContext :: P_Context
+emptyContext = PCtx "" [] Nothing Nothing [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
+
+mergeContexts :: P_Context -> P_Context -> P_Context
+mergeContexts (PCtx nm1 pos1 lang1 markup1 thms1 pats1 pprcs1 rs1 ds1 cs1 ks1 vs1 gs1 ifcs1 ps1 pops1 sql1 php1 metas1)
+              (PCtx nm2 pos2 lang2 markup2 thms2 pats2 pprcs2 rs2 ds2 cs2 ks2 vs2 gs2 ifcs2 ps2 pops2 sql2 php2 metas2) =
+  PCtx{ ctx_nm = nm1
+      , ctx_pos = pos1 ++ pos2
+      , ctx_lang = lang1
+      , ctx_markup = markup1
+      , ctx_thms = thms1 ++ thms2
+      , ctx_pats = pats1 ++ pats2
+      , ctx_PPrcs = pprcs1 ++ pprcs2
+      , ctx_rs = rs1 ++ rs2
+      , ctx_ds = ds1 ++ ds2
+      , ctx_cs = cs1 ++ cs2
+      , ctx_ks = ks1 ++ ks2
+      , ctx_vs = vs1 ++ vs2
+      , ctx_gs = gs1 ++ gs2
+      , ctx_ifcs = ifcs1 ++ ifcs2
+      , ctx_ps = ps1 ++ ps2
+      , ctx_pops = pops1 ++ pops2
+      , ctx_sql = sql1 ++ sql2
+      , ctx_php = php1 ++ php2
+      , ctx_metas = metas1 ++ metas2
+      }
+
+
+parseSingleADL :: ParserVersion -- ^ The specific version of the parser to be used
+         -> String        -- ^ The string to be parsed
+         -> String        -- ^ The name of the .adl file (used for error messages)
+         -> Either ParseError (P_Context, [String]) -- ^ The result: Either some errors, or the parsetree. 
+
+parseSingleADL pv str fn =
+  case pv of
+      Current  -> runParser pv pContext                              fn str
+ where addEmptyIncludes parsedContext = (parsedContext, []) -- the old parsed does not support include filenames, so we add an empty list
+
+
+-- | Same as passeCtx_ , however this one is for a list of populations
+parsePops :: String            -- ^ The string to be parsed
+          -> String            -- ^ The name of the .pop file (used for error messages)
+          -> ParserVersion     -- ^ The specific version of the parser to be used
+          -> Either String [P_Population] -- ^ The result: Either a list of populations, or some errors. 
+parsePops str fn pv = 
+    case  runParser pv pPopulations fn str of
+      Right result -> Right result
+      Left  msg    -> Left $ "Parse errors for "++show pv++":\n"++show msg
+
+
+      
+runParser :: forall res . ParserVersion -> Parser Token res -> String -> String -> Either ParseError res
+runParser parserVersion parser filename input = 
+  let scanner = case parserVersion of 
+                  Current -> scan              keywordstxt              keywordsops              specialchars              opchars filename initPos
+      steps :: Steps (Pair res (Pair [Token] a)) Token
+      steps = parse parser $ scanner input
+  in  case  getMsgs steps of
+        []       -> Right $ let Pair result _ = evalSteps steps in result
+        msg:msgs -> Left msg
+
+ src/lib/DatabaseDesign/Ampersand/InputProcessing.hs view
@@ -0,0 +1,171 @@+{-# OPTIONS_GHC -Wall #-}
+-- This module provides an interface to be able to parse a scritp and to 
+-- return an Fspec, conform the user defined flags. 
+-- This might include that RAP is included in the returned Fspec. 
+module DatabaseDesign.Ampersand.InputProcessing (
+   createFspec
+)
+where
+import qualified DatabaseDesign.Ampersand.Basics as Basics
+import DatabaseDesign.Ampersand.Fspec
+import DatabaseDesign.Ampersand.Misc
+import DatabaseDesign.Ampersand.ADL1.P2A_Converters
+import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner -- (scan,initPos)
+import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing --  (getMsgs,parse,evalSteps,parseIO)
+import DatabaseDesign.Ampersand.Input.ADL1.Parser
+import DatabaseDesign.Ampersand.ADL1
+import DatabaseDesign.Ampersand.Input.ADL1.CtxError (CtxError(PE))
+import Data.List
+import System.Directory
+import System.FilePath
+import Paths_ampersand
+import Control.Monad
+import Data.Traversable (sequenceA)
+
+fatal :: Int -> String -> a
+fatal = Basics.fatalMsg "InputProcessing"
+
+-- | create an Fspec, based on the user defined flags. 
+createFspec :: Options  -- ^The options derived from the command line 
+            -> IO(Guarded Fspc) 
+createFspec flags = 
+  do userCtx <- parseWithIncluded flags (fileName flags)
+     bothCtx <- if includeRap flags
+                then do dataDir <- getDataDir
+                        let rapFile = dataDir </> "AmpersandData" </> "RepoRap" </> "RAP.adl" 
+                        exists <- doesFileExist rapFile
+                        when (not exists) (fatal 39 $ "RAP file isn't installed properly. RAP.adl expected at:"
+                                                    ++"\n  "++show rapFile
+                                                    ++"\n  (You might want to reinstall ampersand...)") 
+                        rapCtx <- parseWithIncluded flags rapFile
+                        popsCtx <- popsCtxOf userCtx
+                        case sequenceA [userCtx, rapCtx, popsCtx] of
+                           Errors err -> return (Errors err)
+                           Checked ps -> return (Checked 
+                                               (foldr mergeContexts emptyContext ps))
+                else return userCtx
+     case bothCtx of
+        Errors err -> return (Errors err)
+        Checked pCtx
+           -> do let (gaCtx) = pCtx2aCtx pCtx 
+                 case gaCtx of
+                   (Errors  err ) -> return (Errors err)
+                   (Checked aCtx) -> return (Checked (makeFspec flags aCtx ))
+  where
+    popsCtxOf :: Guarded P_Context ->IO(Guarded P_Context)
+    popsCtxOf gp =
+     (case gp of
+       Errors _ -> return (Errors []) -- The errors are already in the error list
+       Checked pCtx 
+         -> case pCtx2aCtx pCtx of
+              (Errors  err ) -> return (Errors err)
+              (Checked aCtx)
+                 -> do let fspc = makeFspec flags aCtx
+                           popScript = meatGrinder flags fspc
+                       when (genMeat flags) 
+                          (do let (nm,content) = popScript
+                                  outputFile = combine (dirOutput flags) $ replaceExtension nm ".adl"
+                              writeFile outputFile content
+                              verboseLn flags $ "Meta population written into " ++ outputFile ++ "."
+                          )
+                       case parse1File2pContext popScript of
+                         (Errors  err) -> fatal 64 ("MeatGrinder has errors!" 
+                                                 ++ intercalate "\n"(map showErr err))
+                         (Checked (pCtx,[])) -> return (Checked pCtx)
+                         (Checked (_,includes)) -> fatal 67 "Meatgrinder returns included file????"
+     )
+
+getRapCtxt :: Options ->IO(Guarded P_Context)
+getRapCtxt flags = 
+  do dataDir <- getDataDir
+     let rapFile = dataDir </> "AmpersandData" </> "RepoRap" </> "RAP.adl" 
+     exists <- doesFileExist rapFile
+     when (not exists) (fatal 39 $ "RAP file isn't installed properly. RAP.adl expected at:"
+                              ++"\n  "++show rapFile
+                              ++"\n  (You might want to reinstall ampersand...)") 
+     parseWithIncluded flags rapFile
+     
+-------------
+type FileContent = (FilePath, String) -- The name and its contents
+type ParseResult = (P_Context, [FilePath]) -- A positive parse of a single file deliverse a P_Context and a list of includedes
+
+parseWithIncluded :: Options -> FilePath -> IO(Guarded P_Context)
+parseWithIncluded flags f = tailRounds [] (emptyContext,[f])
+ where
+    tailRounds :: [FileContent] -- the files already processed
+               -> ParseResult   -- the result so far.  
+               -> IO(Guarded P_Context) 
+    tailRounds dones (pCtx, names) =
+     do let filesToProcessThisRound = [f | f<-names, f `notElem` map fst dones]
+        case filesToProcessThisRound of 
+         []    -> do return (Checked pCtx)
+         newNs -> do fs <- readFiles newNs
+                     res <- oneRound fs dones pCtx
+                     case res of
+                             Errors err -> return (Errors err)
+                             Checked (pCtx',included)
+                                -> tailRounds (nub ( dones++fs)) (pCtx', included)
+    readFiles :: [FilePath] -> IO [FileContent]
+    readFiles fs = mapM readFile fs
+     where
+       readFile f = 
+          do verboseLn flags ("reading "++f)
+             content <- Basics.readFile f
+             return (f,content)
+    oneRound :: [FileContent] -> [FileContent] -> P_Context -> IO(Guarded ParseResult)
+    oneRound todos dones pCtx = 
+      do return (parseNext todos dones pCtx)
+     where 
+       parseNext :: [FileContent] -- Files that have not been parsed yet
+                 -> [FileContent] -- Files that have been parsed already
+                 -> P_Context     -- The result so far from previous parsed files
+                 -> Guarded ParseResult
+       parseNext todos dones pCtx =
+         case nub [f | f <- todos, f `notElem` dones] of
+           [] -> Checked (pCtx,[])
+           fs -> case sequenceA (map parse1File2pContext fs) of
+                   Checked prs -> Checked ( foldl mergeContexts pCtx (map fst prs)
+                                          , concatMap snd prs)
+                   Errors errs -> Errors errs
+parse1File2pContext :: FileContent -> Guarded ParseResult
+parse1File2pContext (fPath, fContent) =
+   let scanner = scan keywordstxt keywordsops specialchars opchars fPath initPos
+       steps :: Steps (Pair ParseResult (Pair [Token] a)) Token
+       steps = parse pContext (scanner fContent)
+   in  case  getMsgs steps of
+         []  -> let Pair (pCtx,includes) _ = evalSteps steps 
+                in Checked (pCtx,map normalize includes)
+         msgs-> Errors (map PE msgs)
+  where
+  normalize ::FilePath -> FilePath
+  normalize name = (takeDirectory fPath) </> name
+
+
+ 
+emptyContext :: P_Context
+emptyContext = PCtx "" [] Nothing Nothing [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
+
+mergeContexts :: P_Context -> P_Context -> P_Context
+mergeContexts (PCtx nm1 pos1 lang1 markup1 thms1 pats1 pprcs1 rs1 ds1 cs1 ks1 vs1 gs1 ifcs1 ps1 pops1 sql1 php1 metas1)
+              (PCtx nm2 pos2 lang2 markup2 thms2 pats2 pprcs2 rs2 ds2 cs2 ks2 vs2 gs2 ifcs2 ps2 pops2 sql2 php2 metas2) =
+  PCtx{ ctx_nm  = if null nm1 then nm2 else nm1
+      , ctx_pos = pos1 ++ pos2
+      , ctx_lang = lang1
+      , ctx_markup = markup1
+      , ctx_thms = thms1 ++ thms2
+      , ctx_pats = pats1 ++ pats2
+      , ctx_PPrcs = pprcs1 ++ pprcs2
+      , ctx_rs = rs1 ++ rs2
+      , ctx_ds = ds1 ++ ds2
+      , ctx_cs = cs1 ++ cs2
+      , ctx_ks = ks1 ++ ks2
+      , ctx_vs = vs1 ++ vs2
+      , ctx_gs = gs1 ++ gs2
+      , ctx_ifcs = ifcs1 ++ ifcs2
+      , ctx_ps = ps1 ++ ps2
+      , ctx_pops = pops1 ++ pops2
+      , ctx_sql = sql1 ++ sql2
+      , ctx_php = php1 ++ php2
+      , ctx_metas = metas1 ++ metas2
+      }
+
+ src/lib/DatabaseDesign/Ampersand/Misc.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Misc (module X) where
+import DatabaseDesign.Ampersand.Misc.Languages as X
+       (Lang(..), plural)
+import DatabaseDesign.Ampersand.Misc.Options as X
+       (getOptions, Options(..), defaultFlags, ParserVersion(..),
+        verboseLn, verbose, DocTheme(..), FspecFormat(..),
+        FileFormat(..), helpNVersionTexts)
+import DatabaseDesign.Ampersand.Misc.Explain as X
+       (string2Blocks, blocks2String, PandocFormat(..))
+ src/lib/DatabaseDesign/Ampersand/Misc/Explain.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Misc.Explain
+    ( string2Blocks
+    , blocks2String
+    , PandocFormat(..)
+    )
+where
+
+import Text.Pandoc
+import Data.List (isPrefixOf)
+import DatabaseDesign.Ampersand.Core.ParseTree      (PandocFormat(..))
+
+
+-- | use a suitable format to read generated strings. if you have just normal text, ReST is fine.
+-- | defaultPandocReader flags should be used on user-defined strings.
+string2Blocks :: PandocFormat -> String -> [Block]
+string2Blocks defaultformat str
+ = case blocks of             -- WHY (SJ, dec 7th, 2011): What is the point of changing Para into Plain?
+    [Para is] -> [Plain is]   -- BECAUSE (SJ, dec 7th, 2011): The table of relations in the LaTeX output of ChapterDataAnalysis gives errors when LaTeX is run, because Para generates a newline that LaTeX cannot cope with.
+    _         -> blocks       --                              However, this Para is generated by Pandoc, so I'm wondering whether the mistake is in Pandoc? Anyway, this solution is a dirty fix, which I don't like.
+   where 
+     Pandoc _ blocks = thePandocParser (removeCRs str')
+     removeCRs :: String -> String
+     removeCRs [] = []
+     removeCRs ('\r' :'\n' : xs) = '\n' : removeCRs xs
+     removeCRs (c:xs) = c:removeCRs xs
+     (thePandocParser,str') = whatParser2UseOnWhatString
+     whatParser2UseOnWhatString :: (String -> Pandoc,String)
+     whatParser2UseOnWhatString -- = (readRST, str)
+        | markDownPrefix `isPrefixOf` str = (readMarkdown def, drop (length markDownPrefix) str)
+        | reSTPrefix     `isPrefixOf` str = (readRST      def, drop (length reSTPrefix)     str)
+        | hTMLPrefix     `isPrefixOf` str = (readHtml     def, drop (length hTMLPrefix)     str)
+         --stateParseRaw=True e.g. such that "\ref{something}" is not read as "\{something\}". with parse raw it's read as inline latex
+         --maybe html should be parsed raw too...
+        | laTeXPrefix    `isPrefixOf` str = (readLaTeX    def, drop (length laTeXPrefix)    str)
+        | otherwise   = case defaultformat of
+                               Markdown  -> (readMarkdown def, str)
+                               ReST      -> (readRST      def, str)
+                               HTML      -> (readHtml     def, str)
+                               LaTeX     -> (readLaTeX    def, str)
+       where markDownPrefix = makePrefix Markdown
+             reSTPrefix     = makePrefix ReST
+             hTMLPrefix     = makePrefix HTML
+             laTeXPrefix    = makePrefix LaTeX
+
+makePrefix :: PandocFormat -> String             
+makePrefix format = ":"++show format++":"
+
+-- | write [Block] as String in a certain format using defaultWriterOptions
+blocks2String :: PandocFormat -> Bool -> [Block] -> String
+blocks2String format writeprefix ec 
+ = [c | c<-makePrefix format,writeprefix]
+   --you cannot unwords lines for all writers, because white lines have a meaning in LaTeX i.e. \par
+   --if your application of blocks2String may not have line breaks, then unwords lines there
+   ++ {- unwords -} ( {-lines $ -} writer def (Pandoc nullMeta ec))
+   where writer = case format of
+            Markdown  -> writeMarkdown
+            ReST      -> writeRST
+            HTML      -> writeHtmlString
+            LaTeX     -> writeLaTeX
+ src/lib/DatabaseDesign/Ampersand/Misc/Languages.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS_GHC -Wall #-}
+-- | This module does some string manipulation based on natural languages
+module DatabaseDesign.Ampersand.Misc.Languages
+              (  Lang(English,Dutch)
+               , allLangs
+               , plural
+              ) where
+   import Data.Char (toLower)
+   import Data.List (isSuffixOf)
+   import DatabaseDesign.Ampersand.Core.ParseTree      (Lang(..))
+   
+   allLangs :: [Lang]
+   allLangs = [Dutch,English] -- All supported natural languages in Ampersand
+
+
+   -- | Returns the plural of a given word based on a specific language
+   plural :: Lang -> String -> String
+   plural English str
+    | null str = str
+    | last str=='y' = init str++"ies"
+    | last str=='s' = str++"es"
+    | last str=='x' = str++"es"
+    | last str=='f' = init str++"ves"
+    | otherwise     = head ([p |(s,p)<-exceptions, s==str]++[str++"s"])
+    where exceptions = [("child","children"),("Child","Children"),("mouse","mice"),("Mouse","Mice"),("sheep","sheep"),("Sheep","Sheep")]
+   plural Dutch str
+    | null str = str
+    | not (null matches)    = head matches
+    | take 3 (reverse str)== reverse "ium" = (reverse.drop 3.reverse) str++"ia"
+    | take 2 (reverse str) `elem` map reverse ["el", "em", "en", "er", "um", "ie"] = str++"s"
+    | "ij" `isSuffixOf` str = str++"en"
+    | "io" `isSuffixOf` str = str++"'s"
+    | klinker (last str)    = str++"s"
+    | (take 2.drop 1.reverse) str `elem` ["aa","oo","ee","uu"] = (reverse.drop 2.reverse) str++mede (drop (length str-1) str)++"en"
+    | otherwise                  = str++"en"
+    where mede "f" = "v"
+          mede "s" = "z"
+          mede x = x
+          klinker c = c `elem` "aeiou"
+          matches = [(reverse.drop (length s).reverse) str++p |(s,p) <-exceptions, (map toLower.reverse.take (length s).reverse) str==s]
+          exceptions = [ ("aanbod", "aanbiedingen")
+                       , ("beleg", "belegeringen")
+                       , ("dank", "dankbetuigingen")
+                       , ("gedrag", "gedragingen")
+                       , ("genot", "genietingen")
+                       , ("lof", "loftuitingen")
+                       , ("lende", "lendenen")
+                       , ("onderzoek", "onderzoekingen")
+                       , ("archiefstuk", "archiefbescheiden")
+                       , ("titel", "titels")
+                       , ("plan", "plannen")
+                       , ("kind", "kinderen")
+                       ]
+ src/lib/DatabaseDesign/Ampersand/Misc/Options.hs view
@@ -0,0 +1,475 @@+{-# LANGUAGE PatternGuards #-}
+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Misc.Options 
+        (Options(..),getOptions,defaultFlags,usageInfo'
+        ,ParserVersion(..)
+        ,verboseLn,verbose,FspecFormat(..),FileFormat(..)
+        ,DocTheme(..),allFspecFormats,helpNVersionTexts)
+where
+import System.Environment    (getArgs, getProgName,getEnvironment)
+import DatabaseDesign.Ampersand.Misc.Languages (Lang(..))
+import Data.Char (toUpper)
+import System.Console.GetOpt
+import System.FilePath
+import System.Directory
+import Data.Time.Clock
+import Data.Time.LocalTime
+import Control.Monad
+import Data.Maybe
+import DatabaseDesign.Ampersand.Basics  
+import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)
+import Data.List
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Misc.Options"
+
+data ParserVersion = Current | Legacy deriving Eq
+
+instance Show ParserVersion where
+  show Current = "syntax since Ampersand 2.1.1."
+  show Legacy = "syntax664"
+
+-- | This data constructor is able to hold all kind of information that is useful to 
+--   express what the user would like Ampersand to do. 
+data Options = Options { showVersion :: Bool
+                       , preVersion :: String
+                       , postVersion :: String  --built in to aid DOS scripting... 8-(( Bummer. 
+                       , showHelp :: Bool
+                       , verboseP :: Bool
+                       , development :: Bool
+                       , validateSQL :: Bool
+                       , genPrototype :: Bool 
+                       , autoid :: Bool --implies forall Concept A => value::A->Datatype [INJ]. where instances of A are autogenerated 
+                       , dirPrototype :: String  -- the directory to generate the prototype in.
+                       , allInterfaces :: Bool
+                       , dbName :: String
+                       , genAtlas :: Bool
+                       , namespace :: String
+                       , autoRefresh :: Maybe Int
+                       , testRule :: Maybe String                       
+                       , customCssFile :: Maybe FilePath                       
+                       , importfile :: FilePath --a file with content to populate some (Populated a)
+                                                   --class Populated a where populate::a->b->a
+                       , fileformat :: FileFormat --file format e.g. of importfile or export2adl
+                       , theme :: DocTheme --the theme of some generated output. (style, content differentiation etc.)
+                       , genXML :: Bool
+                       , genFspec :: Bool   -- if True, generate a functional specification
+                       , diag :: Bool   -- if True, generate a diagnosis only
+                       , fspecFormat :: FspecFormat
+                       , genGraphics :: Bool   -- if True, graphics will be generated for use in Ampersand products like the Atlas or Functional Spec
+                       , genEcaDoc :: Bool   -- if True, generate ECA rules in the Functional Spec
+                       , proofs :: Bool
+                       , haskell :: Bool   -- if True, generate the F-structure as a Haskell source file
+                       , dirOutput :: String -- the directory to generate the output in.
+                       , outputfile :: String -- the file to generate the output in.
+                       , crowfoot :: Bool   -- if True, generate conceptual models and data models in crowfoot notation
+                       , blackWhite :: Bool   -- only use black/white in graphics
+                       , doubleEdges :: Bool   -- Graphics are generated with hinge nodes on edges.    
+                       , showPredExpr :: Bool   -- for generated output, show predicate logic?
+                       , noDiagnosis :: Bool   -- omit the diagnosis chapter from the functional specification document
+                       , diagnosisOnly :: Bool   -- give a diagnosis only (by omitting the rest of the functional specification document)
+                       , genLegalRefs :: Bool   -- Generate a table of legal references in Natural Language chapter
+                       , genUML :: Bool   -- Generate a UML 2.0 data model
+                       , genFPAExcel :: Bool   -- Generate an Excel workbook containing Function Point Analisys
+                       , genBericht :: Bool
+                       , genMeat :: Bool  -- Generate the meta-population and output it to an .adl file
+                       , language :: Lang
+                       , dirExec :: String --the base for relative paths to input files
+                       , progrName :: String --The name of the adl executable
+                       , fileName :: FilePath --the file with the Ampersand context
+                       , baseName :: String
+                       , logName :: String
+                       , genTime :: LocalTime
+                       , export2adl :: Bool
+                       , test :: Bool
+                       , includeRap :: Bool  -- When set, the standard RAP is 'merged' into the generated prototype.(experimental)
+                       , pangoFont :: String  -- use specified font in PanDoc. May be used to avoid pango-warnings.
+                       , sqlHost :: Maybe String  -- do database queries to the specified host
+                       , sqlLogin :: Maybe String  -- pass login name to the database server
+                       , sqlPwd :: Maybe String  -- pass password on to the database server
+                       , parserVersion :: ParserVersion
+                       } deriving Show
+  
+defaultFlags :: Options 
+defaultFlags = Options {genTime       = fatal 81 "No monadic options available."
+                      , dirOutput     = fatal 82 "No monadic options available."
+                      , outputfile    = fatal 83 "No monadic options available."
+                      , autoid        = False
+                      , dirPrototype  = fatal 84 "No monadic options available."
+                      , dbName        = fatal 85 "No monadic options available."
+                      , logName       = fatal 86 "No monadic options available."
+                      , dirExec       = fatal 87 "No monadic options available."
+                      , preVersion    = fatal 88 "No monadic options available."
+                      , postVersion   = fatal 89 "No monadic options available."
+                      , theme         = DefaultTheme
+                      , showVersion   = False
+                      , showHelp      = False
+                      , verboseP      = False
+                      , development   = False
+                      , validateSQL   = False
+                      , genPrototype  = False
+                      , allInterfaces = False
+                      , genAtlas      = False   
+                      , namespace     = []
+                      , autoRefresh   = Nothing
+                      , testRule      = Nothing
+                      , customCssFile = Nothing
+                      , importfile    = []
+                      , fileformat    = fatal 101 "--fileformat is required for --import."
+                      , genXML        = False
+                      , genFspec      = False 
+                      , diag          = False 
+                      , fspecFormat   = fatal 105 $ "Unknown fspec format. Currently supported formats are "++allFspecFormats++"."
+                      , genGraphics   = True
+                      , genEcaDoc     = False
+                      , proofs        = False
+                      , haskell       = False
+                      , crowfoot      = False
+                      , blackWhite    = False
+                      , doubleEdges   = False
+                      , showPredExpr  = False
+                      , noDiagnosis   = False
+                      , diagnosisOnly = False
+                      , genLegalRefs  = False
+                      , genUML        = False
+                      , genFPAExcel   = False
+                      , genBericht    = False
+                      , genMeat       = False
+                      , language      = Dutch
+                      , progrName     = fatal 118 "No monadic options available."
+                      , fileName      = fatal 119 "no default value for fileName."
+                      , baseName      = fatal 120 "no default value for baseName."
+                      , export2adl    = False
+                      , test          = False
+                      , includeRap    = False
+                      , pangoFont     = "Sans"
+                      , sqlHost       = Nothing
+                      , sqlLogin      = Nothing
+                      , sqlPwd        = Nothing
+                      , parserVersion = Current
+                      }
+                
+getOptions :: IO Options
+getOptions =
+   do args     <- getArgs
+      progName <- getProgName
+      let usage = "\nType '"++ progName++" --help' for usage info."
+      let (o,n,errs) = getOpt Permute (each options) args
+      when ((not.null) errs) (error $ concat errs ++ usage)
+      defaultOpts <- defaultOptionsM (head (n++(error $ "Please supply the name of an ampersand file" ++ usage)))
+      let flags = foldl (flip id) defaultOpts o
+      if showHelp flags || showVersion flags
+      then return flags
+      else checkNSetOptionsAndFileNameM (flags,n) usage
+        
+  where 
+     defaultOptionsM :: String -> IO Options 
+     defaultOptionsM fName =
+           do utcTime <- getCurrentTime
+              timeZone <- getCurrentTimeZone
+              let localTime = utcToLocalTime timeZone utcTime
+              progName <- getProgName
+              exePath <- findExecutable progName
+              env <- getEnvironment
+              return
+               defaultFlags
+                      { genTime       = localTime
+                      , dirOutput     = fromMaybe "."       (lookup envdirOutput    env)
+                      , dirPrototype  = fromMaybe ("." </> (addExtension (takeBaseName fName) ".proto"))
+                                                  (lookup envdirPrototype env) </> (addExtension (takeBaseName fName) ".proto")
+                      , dbName        = fromMaybe ""        (lookup envdbName       env)
+                      , logName       = fromMaybe "Ampersand.log" (lookup envlogName      env)
+                      , dirExec       = case exePath of
+                                          Nothing -> fatal 155 $ "Specify the path location of "++progName++" in your system PATH variable."
+                                          Just s  -> takeDirectory s
+                      , preVersion    = fromMaybe ""        (lookup "CCPreVersion"  env)
+                      , postVersion   = fromMaybe ""        (lookup "CCPostVersion" env)
+                      , progrName     = progName
+                      }
+
+
+
+     checkNSetOptionsAndFileNameM :: (Options,[String]) -> String -> IO Options 
+     checkNSetOptionsAndFileNameM (flags,fNames) usage= 
+          if showVersion flags || showHelp flags 
+          then return flags 
+          else case fNames of
+                []      -> error $ "no file to parse" ++usage
+                [fName] -> verboseLn flags "Checking output directories..."
+                        >> checkLogName flags
+                        >> checkDirOutput flags
+                        --REMARK -> checkExecOpts in comments because it is redundant
+                        --          it may throw fatals about PATH not set even when you do not need the dir of the executable.
+                        --          if you need the dir of the exec, then you should use (dirExec flags) which will throw the fatal about PATH when needed.
+                        -- >> checkExecOpts flags
+                        >> checkProtoOpts flags
+                        >> return flags { fileName    = if hasExtension fName
+                                                         then fName
+                                                         else addExtension fName "adl" 
+                                        , baseName    = takeBaseName fName
+                                        , dbName      = case dbName flags of
+                                                            ""  -> takeBaseName fName
+                                                            str -> str
+                                        , genAtlas = not (null(importfile flags)) && fileformat flags==Adl1Format
+                                        , importfile  = if null(importfile flags) || hasExtension(importfile flags)
+                                                        then importfile flags
+                                                        else case fileformat flags of 
+                                                                Adl1Format -> addExtension (importfile flags) "adl"
+                                                                Adl1PopFormat -> addExtension (importfile flags) "pop"
+                                        }
+                x:xs    -> error $ "too many files: "++ intercalate ", " (x:xs) ++usage
+       
+       where
+          checkLogName :: Options -> IO ()
+          checkLogName   f = createDirectoryIfMissing True (takeDirectory (logName f))
+          checkDirOutput :: Options -> IO ()
+          checkDirOutput f = createDirectoryIfMissing True (dirOutput f)
+
+          --checkExecOpts :: Options -> IO ()
+          --checkExecOpts f = do execPath <- findExecutable (progrName f) 
+            --                   when (execPath == Nothing) 
+              --                      (fatal 206 $ "Specify the path location of "++(progrName f)++" in your system PATH variable.")
+          checkProtoOpts :: Options -> IO ()
+          checkProtoOpts f = when (genPrototype f) (createDirectoryIfMissing True (dirPrototype f))
+            
+data DisplayMode = Public | Hidden 
+
+data FspecFormat = FPandoc| Fasciidoc| Fcontext| Fdocbook| Fhtml| FLatex| Fman| Fmarkdown| Fmediawiki| Fopendocument| Forg| Fplain| Frst| Frtf| Ftexinfo| Ftextile deriving (Show, Eq)
+allFspecFormats :: String
+allFspecFormats = show (map (tail . show) [FPandoc, Fasciidoc, Fcontext, Fdocbook, Fhtml, FLatex, Fman, Fmarkdown, Fmediawiki, Fopendocument, Forg, Fplain, Frst, Frtf, Ftexinfo, Ftextile])
+
+data FileFormat = Adl1Format | Adl1PopFormat  deriving (Show, Eq) --file format that can be parsed to some b to populate some Populated a
+data DocTheme = DefaultTheme   -- Just the functional specification
+              | ProofTheme     -- A document with type inference proofs
+              | StudentTheme   -- Output for normal students of the business rules course
+              | StudentDesignerTheme   -- Output for advanced students of the business rules course
+              | DesignerTheme   -- Output for non-students
+                 deriving (Show, Eq)
+    
+usageInfo' :: Options -> String
+-- When the user asks --help, then the public options are listed. However, if also --verbose is requested, the hidden ones are listed too.  
+usageInfo' flags = usageInfo (infoHeader (progrName flags)) (if verboseP flags then each options else publics options)
+          
+infoHeader :: String -> String
+infoHeader progName = "\nUsage info:\n " ++ progName ++ " options file ...\n\nList of options:"
+
+publics :: [(a, DisplayMode) ] -> [a]
+publics flags = [o | (o,Public)<-flags]
+each :: [(a, DisplayMode) ] -> [a]
+each flags = [o |(o,_) <- flags]
+
+options :: [(OptDescr (Options -> Options), DisplayMode) ]
+options = map pp
+          [ (Option "v"     ["version"]     (NoArg versionOpt)          "show version and exit.", Public)
+          , (Option "h?"    ["help"]        (NoArg helpOpt)             "get (this) usage information.", Public)
+          , (Option ""      ["verbose"]     (NoArg verboseOpt)          "verbose error message format.", Public)
+          , (Option ""      ["dev"]         (NoArg developmentOpt)      "Report and generate extra development information", Hidden)
+          , (Option ""      ["validate"]    (NoArg (\flags -> flags{validateSQL = True}))  "Compare results of rule evaluation in Haskell and SQL (requires command line php with MySQL support)", Hidden)
+          , (Option "p"     ["proto"]       (OptArg prototypeOpt "dir") ("generate a functional prototype (overwrites environment variable "
+                                                                           ++ envdirPrototype ++ ")."), Public)
+          , (Option "d"     ["dbName"]      (ReqArg dbNameOpt "name")   ("database name (overwrites environment variable "
+                                                                           ++ envdbName ++ ", defaults to filename)"), Public)
+          , (Option []      ["theme"]       (ReqArg themeOpt "theme")   "differentiate between certain outputs e.g. student", Public)
+          , (Option "x"     ["interfaces"]  (NoArg maxInterfacesOpt)    "generate interfaces.", Public)
+          , (Option "e"     ["export"]      (OptArg exportOpt "file") "export as ASCII Ampersand syntax.", Public)
+          , (Option "o"     ["outputDir"]   (ReqArg outputDirOpt "dir") ("output directory (dir overwrites environment variable "
+                                                                           ++ envdirOutput ++ ")."), Public)
+          , (Option []      ["log"]         (ReqArg logOpt "name")      ("log file name (name overwrites environment variable "
+                                                                           ++ envlogName  ++ ")."), Hidden)
+          , (Option []      ["import"]      (ReqArg importOpt "file")   "import this file as the population of the context.", Public)
+          , (Option []      ["fileformat"]  (ReqArg formatOpt "format")("format of import file (format="
+                                                                           ++allFileFormats++")."), Public)
+          , (Option []      ["namespace"]   (ReqArg namespaceOpt "ns")  "places the population in this namespace within the context.", Public)
+          , (Option "f"     ["fspec"]       (ReqArg fspecRenderOpt "format")  
+                                                                         ("generate a functional specification document in specified format (format="
+                                                                         ++allFspecFormats++")."), Public)
+          , (Option []        ["refresh"]     (OptArg autoRefreshOpt "interval") "Experimental auto-refresh feature", Hidden)
+          , (Option []        ["testRule"]    (ReqArg (\ruleName flags -> flags{ testRule = Just ruleName }) "rule name")
+                                                                          "Show contents and violations of specified rule.", Hidden)
+          , (Option []        ["css"]         (ReqArg (\pth flags -> flags{ customCssFile = Just pth }) "file")
+                                                                          "Custom.css file to customize the style of the prototype.", Public)
+          , (Option []        ["noGraphics"]  (NoArg noGraphicsOpt)       "save compilation time by not generating any graphics.", Public)
+          , (Option []        ["ECA"]         (NoArg genEcaDocOpt)        "generate documentation with ECA rules.", Public)
+          , (Option []        ["proofs"]      (NoArg proofsOpt)           "generate derivations.", Public)
+          , (Option []        ["XML"]         (NoArg xmlOpt)              "generate internal data structure, written in XML (for debugging).", Public)
+          , (Option []        ["haskell"]     (NoArg haskellOpt)          "generate internal data structure, written in Haskell (for debugging).", Public)
+          , (Option []        ["crowfoot"]    (NoArg crowfootOpt)         "generate crowfoot notation in graphics.", Public)
+          , (Option []        ["blackWhite"]  (NoArg blackWhiteOpt)       "do not use colours in generated graphics", Public)
+          , (Option []        ["doubleEdges"] (NoArg doubleEdgesOpt)      "generate graphics in an alternate way. (you may experiment with this option to see the differences for yourself)", Public)
+          , (Option []        ["predLogic"]   (NoArg predLogicOpt)        "show logical expressions in the form of predicate logic." , Public)
+          , (Option []        ["noDiagnosis"] (NoArg noDiagnosisOpt)      "omit the diagnosis chapter from the functional specification document." , Public)
+          , (Option []        ["diagnosis"]   (NoArg diagnosisOpt)        "diagnose your Ampersand script (generates a .pdf file).", Public)
+          , (Option []        ["legalrefs"]   (NoArg (\flags -> flags{genLegalRefs = True}))
+                                                                          "generate a table of legal references in Natural Language chapter.", Public)
+          , (Option []        ["uml"]         (NoArg (\flags -> flags{genUML = True}))
+                                                                          "Generate a UML 2.0 data model.", Hidden)
+          , (Option []        ["FPA"]         (NoArg (\flags -> flags{genFPAExcel = True}))
+                                                                          "Generate a Excel workbook (.xls).", Hidden)
+          , (Option []        ["bericht"]     (NoArg (\flags -> flags{genBericht = True}))
+                                                                          "Generate definitions for 'berichten' (specific to INDOORS project).", Hidden)
+          , (Option []        ["language"]    (ReqArg languageOpt "lang") "language to be used, ('NL' or 'EN').", Public)
+          , (Option []        ["test"]        (NoArg testOpt)             "Used for test purposes only.", Hidden)
+          , (Option []        ["rap"]         (NoArg (\flags -> flags{includeRap = True}))
+                                                                          "Include RAP into the generated artifacts (experimental)", Hidden)
+          , (Option []        ["meta"]        (NoArg (\flags -> flags{genMeat = True}))
+                                                                          "Generate meta-population in an .adl file (experimental)", Hidden)
+          , (Option []        ["pango"]       (OptArg pangoOpt "fontname") "specify font name for Pango in graphics.", Hidden)
+          , (Option []        ["sqlHost"]     (OptArg sqlHostOpt "name")  "specify database host name.", Hidden)
+          , (Option []        ["sqlLogin"]    (OptArg sqlLoginOpt "name") "specify database login name.", Hidden)
+          , (Option []        ["sqlPwd"]      (OptArg sqlPwdOpt "str")    "specify database password.", Hidden)
+          , (Option []        ["forceSyntax"] (ReqArg forceSyntaxOpt "versionNumber") "version number of the syntax to be used, ('1' or '2'). Without this, ampersand will guess the version used.", Public) 
+          ]
+     where pp :: (OptDescr (Options -> Options), DisplayMode) -> (OptDescr (Options -> Options), DisplayMode)
+           pp (Option a b' c d,e) = (Option a b' c d',e)
+              where d' =  afkappen [] [] (words d) 40
+                    afkappen :: [[String]] -> [String] -> [String] -> Int -> String
+                    afkappen regels []    []   _ = intercalate "\n" (map unwords regels)
+                    afkappen regels totnu []   b = afkappen (regels++[totnu]) [] [] b
+                    afkappen regels totnu (w:ws) b 
+                          | length (unwords totnu) < b - length w = afkappen regels (totnu++[w]) ws b
+                          | otherwise                             = afkappen (regels++[totnu]) [w] ws b     
+           
+                    
+envdirPrototype :: String
+envdirPrototype = "CCdirPrototype"
+envdirOutput :: String
+envdirOutput="CCdirOutput"
+envdbName :: String
+envdbName="CCdbName"
+envlogName :: String
+envlogName="CClogName"
+
+versionOpt :: Options -> Options
+versionOpt       flags = flags{showVersion  = True}            
+helpOpt :: Options -> Options
+helpOpt          flags = flags{showHelp     = True}            
+verboseOpt :: Options -> Options
+verboseOpt       flags = flags{ verboseP     = True} 
+developmentOpt :: Options -> Options
+developmentOpt flags = flags{ development   = True}
+autoRefreshOpt :: Maybe String -> Options -> Options
+autoRefreshOpt (Just interval) flags | [(i,"")] <- reads interval = flags{autoRefresh = Just i}
+autoRefreshOpt _               flags                              = flags{autoRefresh = Just 5}
+prototypeOpt :: Maybe String -> Options -> Options
+prototypeOpt nm flags 
+  = flags { dirPrototype = fromMaybe (dirPrototype flags) nm
+         , genPrototype = True}
+importOpt :: String -> Options -> Options
+importOpt nm flags 
+  = flags { importfile = nm }
+formatOpt :: String -> Options -> Options
+formatOpt f flags = case map toUpper f of
+     "ADL" -> flags{fileformat = Adl1Format}
+     "ADL1"-> flags{fileformat = Adl1Format}
+     "POP" -> flags{fileformat = Adl1PopFormat}
+     "POP1"-> flags{fileformat = Adl1PopFormat}
+     _     -> flags
+maxInterfacesOpt :: Options -> Options
+maxInterfacesOpt  flags = flags{allInterfaces  = True}                            
+themeOpt :: String -> Options -> Options
+themeOpt t flags = flags{theme = case map toUpper t of 
+                                    "STUDENT" -> StudentTheme
+                                    "STUDENTDESIGNER" -> StudentDesignerTheme
+                                    "DESIGNER" -> DesignerTheme
+                                    "PROOF"   -> ProofTheme
+                                    _         -> DefaultTheme}
+dbNameOpt :: String -> Options -> Options
+dbNameOpt nm flags = flags{dbName = if nm == "" 
+                                    then baseName flags
+                                    else nm
+                        }                          
+namespaceOpt :: String -> Options -> Options
+namespaceOpt x flags = flags{namespace = x}
+xmlOpt :: Options -> Options
+xmlOpt          flags = flags{genXML       = True}
+fspecRenderOpt :: String -> Options -> Options
+fspecRenderOpt w flags = flags{ genFspec=True
+                            , fspecFormat= case map toUpper w of
+                                  ('A': _ )         -> Fasciidoc
+                                  ('C': _ )         -> Fcontext
+                                  ('D': _ )         -> Fdocbook
+                                  ('H': _ )         -> Fhtml
+                                  ('L': _ )         -> FLatex
+                                  ('M':'A':'N': _ ) -> Fman
+                                  ('M':'A': _ )     -> Fmarkdown
+                                  ('M':'E': _ )     -> Fmediawiki
+                                  ('O':'P': _ )     -> Fopendocument
+                                  ('O':'R': _ )     -> Forg
+                                  ('P':'A': _ )     -> FPandoc
+                                  ('P':'L': _ )     -> Fplain
+                                  ('R':'S': _ )     -> Frst
+                                  ('R':'T': _ )     -> Frtf
+                                  ('T':'E':'X':'I': _ ) -> Ftexinfo
+                                  ('T':'E':'X':'T': _ ) -> Ftextile
+                                  _         -> fspecFormat flags
+
+                                                
+                            }
+allFileFormats :: String
+allFileFormats                    = "ADL (.adl), ADL1 (.adl), POP (.pop), POP1 (.pop)"
+noGraphicsOpt :: Options -> Options
+noGraphicsOpt flags                  = flags{genGraphics   = False}
+genEcaDocOpt :: Options -> Options
+genEcaDocOpt flags                   = flags{genEcaDoc     = True}
+proofsOpt :: Options -> Options
+proofsOpt flags                      = flags{proofs        = True}
+exportOpt :: Maybe String -> Options -> Options
+exportOpt mbnm flags                 = flags{export2adl    = True
+                                          ,outputfile    = fromMaybe "Export.adl" mbnm}
+haskellOpt :: Options -> Options
+haskellOpt flags                     = flags{haskell       = True}
+outputDirOpt :: String -> Options -> Options
+outputDirOpt nm flags                = flags{dirOutput     = nm}
+crowfootOpt :: Options -> Options
+crowfootOpt flags                    = flags{crowfoot      = True}
+blackWhiteOpt :: Options -> Options
+blackWhiteOpt flags                  = flags{blackWhite    = True}
+doubleEdgesOpt :: Options -> Options
+doubleEdgesOpt flags                 = flags{doubleEdges   = not (doubleEdges flags)}
+predLogicOpt :: Options -> Options
+predLogicOpt flags                   = flags{showPredExpr  = True}
+noDiagnosisOpt :: Options -> Options
+noDiagnosisOpt flags                 = flags{noDiagnosis   = True}
+diagnosisOpt :: Options -> Options
+diagnosisOpt flags                   = flags{diagnosisOnly = True}
+languageOpt :: String -> Options -> Options
+languageOpt l flags                  = flags{language = case map toUpper l of
+                                                       "NL"  -> Dutch
+                                                       "UK"  -> English
+                                                       "US"  -> English
+                                                       "EN"  -> English
+                                                       _     -> Dutch}
+forceSyntaxOpt :: String -> Options -> Options
+forceSyntaxOpt s flags               = flags{parserVersion = case s of
+                                              "1" -> Legacy
+                                              "2" -> Current
+                                              "0" -> Current --indicates latest
+                                              _   -> error $ "Unknown value for syntax version: "++s++". Known values are 0, 1 or 2. 0 indicates latest."
+                                          } 
+logOpt :: String -> Options -> Options
+logOpt nm flags                      = flags{logName       = nm}
+pangoOpt :: Maybe String -> Options -> Options
+pangoOpt (Just nm) flags             = flags{pangoFont     = nm}
+pangoOpt Nothing  flags              = flags
+sqlHostOpt :: Maybe String -> Options -> Options
+sqlHostOpt mnm flags           = flags{sqlHost       = mnm}
+sqlLoginOpt :: Maybe String -> Options -> Options
+sqlLoginOpt mnm flags          = flags{sqlLogin      = mnm}
+sqlPwdOpt :: Maybe String -> Options -> Options
+sqlPwdOpt mnm flags            = flags{sqlPwd        = mnm}
+testOpt :: Options -> Options
+testOpt flags                        = flags{test          = True}
+
+verbose :: Options -> String -> IO ()
+verbose flags x
+   | verboseP flags = putStr x
+   | otherwise      = return ()
+   
+verboseLn :: Options -> String -> IO ()
+verboseLn flags x
+   | verboseP flags = -- each line is handled separately, so the buffer will be flushed in time. (see ticket #179)
+                      mapM_ putStrLn (lines x)
+   | otherwise      = return ()
+helpNVersionTexts :: String -> Options -> [String]
+helpNVersionTexts vs flags          = [preVersion flags++vs++postVersion flags++"\n" | showVersion flags]++
+                                      [usageInfo' flags                              | showHelp    flags]
+ src/lib/DatabaseDesign/Ampersand/Misc/TinyXML.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Misc.TinyXML where
+
+   -----------------some new data types for simple XML structures--------
+   data XTree = Elem { etag :: XTag
+                     , etrees :: [XTree]
+                     }
+              | Node { ntag :: XTag  -- WHY? is Node nodig? Immers een Elem met een lege etrees doet precies hetzelfde...
+                                      -- BECAUSE! De show van een Node laat maar één tag zien. Een Elem showt een begin- en end-tag.
+                     }
+              | PlainText {ptstr :: String}
+   data XTag =  Tag  { tName :: String
+                     , tAtts :: [XAtt]
+                     }
+   data XAtt = Att { attName :: String
+                   , attValue :: String
+                   }
+
+
+   showXTree :: XTree -> String
+   showXTree tree = case tree of
+                        Elem{} -> showStart tag
+                               ++ concatMap showXTree (etrees tree)
+                               ++ showEnd tag
+                                   where tag = etag tree
+                        Node{} -> showNode (ntag tree)
+                        PlainText{} -> show (ptstr tree)
+   showStart :: XTag -> String
+   showStart a = "<" ++ tName a ++ showAtts (tAtts a) ++ ">" 
+  
+   showAtts :: [XAtt] -> String
+   showAtts = concatMap showAtt
+      where showAtt :: XAtt -> String
+            showAtt a= " "++attName a++"="++show (attValue a)
+
+   showEnd :: XTag -> String
+   showEnd a = "</" ++ tName a ++ ">"   
+   
+   showNode :: XTag -> String
+   showNode a = "<" ++ tName a ++ showAtts (tAtts a) ++ "/>"   
+
+   mkAttr :: String -> String -> XAtt
+   mkAttr  = Att 
+   
+   simpleTag :: String -> XTag
+   simpleTag nm = Tag nm []
+
+ src/lib/DatabaseDesign/Ampersand/Output.hs view
@@ -0,0 +1,6 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Output (module X) where
+import DatabaseDesign.Ampersand.Output.Fspec2Pandoc as X
+       (fSpec2Pandoc)
+import DatabaseDesign.Ampersand.Output.PandocAux as X (writepandoc)
+import DatabaseDesign.Ampersand.Output.Fspec2Excel as X
+ src/lib/DatabaseDesign/Ampersand/Output/Fspec2Excel.hs view
@@ -0,0 +1,153 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Output.Fspec2Excel (fspec2Workbook,showSpreadsheet)
+where
+import Text.XML.SpreadsheetML.Builder
+import Text.XML.SpreadsheetML.Types
+import Text.XML.SpreadsheetML.Writer (showSpreadsheet)
+import DatabaseDesign.Ampersand.Misc
+import DatabaseDesign.Ampersand.Fspec
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+import DatabaseDesign.Ampersand.Fspec.FPA
+import DatabaseDesign.Ampersand.Basics
+
+fspec2Workbook :: Fspc -> Options -> Workbook
+fspec2Workbook fSpec flags =
+   Workbook
+      { workbookDocumentProperties = Just
+          DocumentProperties { documentPropertiesTitle = Just $ "FunctiePuntAnalyse van "++baseName flags
+                             , documentPropertiesSubject = Nothing
+                             , documentPropertiesKeywords  = Nothing
+                             , documentPropertiesDescription = Just $ "Dit document is gegenereerd dmv. "++ampersandVersionStr++"."
+                             , documentPropertiesRevision = Nothing
+                             , documentPropertiesAppName = Just "Ampersand"
+                             , documentPropertiesCreated = Just $ show (genTime flags)
+                             }
+      , workbookWorksheets = [pimpWs wsResume,pimpWs wsDatasets,pimpWs wsFunctions]
+      }
+  where
+    lang = language flags
+    wsResume =
+      Worksheet { worksheetName =
+                            Name $ case lang of
+                                    English -> "Resume"
+                                    Dutch   -> "Overzicht"
+                , worksheetTable = Just $ emptyTable 
+                    { tableRows = 
+                          [ mkRow [string $ case lang of
+                                               English -> "Detailed function point count (according to NESMA 2.1) of the application "
+                                               Dutch   -> "Gedetailleerde functiepunentelling (volgens NESMA 2.2) van het systeem "
+                                             ++ baseName flags
+                                  ]
+                          , emptyRow
+                          , mkRow [string totalen]
+                          , mkRow [string gegevensverzamelingen,(number.fromIntegral) totaalFPgegevensverzamelingen]
+                          , mkRow [string gebruikerstransacties,(number.fromIntegral) totaalFPgebruikerstransacties]
+                          , mkRow [string grandTotaal,(number.fromIntegral) (totaalFPgegevensverzamelingen + totaalFPgebruikerstransacties)]
+                          , emptyRow
+                          , mkRow [string $ case lang of
+                                    English -> "For this function point count it is assumed that:"
+                                    Dutch   -> "Voor deze telling is aangenomen dat:"
+                                  ]
+                          , mkRow [string $ case lang of
+                                    English -> "- the application is built from scratch."
+                                    Dutch   -> "- het een nieuw informatiesyteem betreft."
+                                  ]
+                          , mkRow [string $ case lang of
+                                    English -> "- all persistent information will be stored internally"
+                                    Dutch   -> "- alle informatie wordt intern opgeslagen"
+                                  ]
+                          ]
+                    }
+                }    
+    wsDatasets = 
+      Worksheet { worksheetName = Name $ gegevensverzamelingen
+                , worksheetTable = Just $ emptyTable 
+                    { tableRows = 
+                          [ mkRow [string gegevensverzamelingen, (number.fromIntegral.length.plugInfos) fSpec]
+                          ] ++ 
+                          map (mkRow.showDetailsOfPlug)(plugInfos fSpec)
+                       ++ map mkRow [replicate 3 emptyCell ++ [string totaal, (number.fromIntegral) totaalFPgegevensverzamelingen]]
+                    }
+                }
+    -- TODO: Also count the PHP plugs
+    totaalFPgegevensverzamelingen :: Int
+    totaalFPgegevensverzamelingen = (sum.(map fPoints)) [pSql | InternalPlug pSql <- plugInfos fSpec]
+    wsFunctions = 
+      Worksheet { worksheetName  = Name $ gebruikerstransacties
+                , worksheetTable = Just $ emptyTable 
+                    { tableRows = 
+                          [ mkRow [string $ gebruikerstransacties, (number.fromIntegral.length.interfaceS) fSpec]
+                          ] 
+                          ++ map (mkRow.showDetailsOfFunction) (interfaceS fSpec)
+                          ++ map mkRow [replicate 4 emptyCell ++ [string totaal, (number.fromIntegral.sum.(map fPoints)) (interfaceS fSpec)]]
+                          ++ map mkRow [[string "Gegenereerde interfaces" , (number.fromIntegral.length.interfaceG) fSpec]]
+                          ++ map (mkRow.showDetailsOfFunction) (interfaceG fSpec)
+                          ++ map mkRow [replicate 4 emptyCell ++ [string totaal, (number.fromIntegral.sum.(map fPoints)) (interfaceG fSpec)]]
+                          ++ map mkRow [replicate 5 emptyCell ++ [string grandTotaal, (number.fromIntegral) totaalFPgebruikerstransacties ]]
+                    }
+                }
+    totaalFPgebruikerstransacties :: Int
+    totaalFPgebruikerstransacties = (sum.(map fPoints)) (interfaceS fSpec++interfaceG fSpec)
+    gegevensverzamelingen :: String
+    gegevensverzamelingen = case lang of
+       Dutch   -> "Gegevensverzamelingen"
+       English -> "Data function types"
+
+    gebruikerstransacties :: String
+    gebruikerstransacties = case lang of
+       Dutch   -> "Gebruikerstransacties"
+       English -> "Transactional function types"
+    totalen :: String
+    totalen = case lang of
+       Dutch   -> "Totalen:"
+       English -> "Totals:"
+    totaal :: String
+    totaal = case lang of
+       Dutch   -> "Totaal:"
+       English -> "Total:"
+    grandTotaal :: String
+    grandTotaal = case lang of
+       Dutch   -> "Grandtotaal:"
+       English -> "Grand total:"
+    
+    showDetailsOfPlug :: PlugInfo -> [Cell]
+    showDetailsOfPlug plug =
+       [ emptyCell
+       , (string.name) plug
+       , string (case plug of
+                  InternalPlug p -> showLang lang (fpa p)
+                  ExternalPlug _ -> "???"
+                )
+       , (number.fromIntegral) (case plug of
+                                 InternalPlug p -> fPoints p
+                                 ExternalPlug _ -> 0
+                               )
+       , string ( case (lang,plug) of
+                   (English, ExternalPlug _)             -> "PHP plugs are not (yet) taken into account!"
+                   (Dutch  , ExternalPlug _)             -> "PHP plugs worden (nog) niet meegerekend!"
+                   (English, InternalPlug p@TblSQL{})    -> "Table with "++(show.length.fields) p++" attributes."
+                   (Dutch  , InternalPlug p@TblSQL{})    -> "Tabel met "++(show.length.fields) p++" attributen."
+                   (English, InternalPlug   BinSQL{})    -> "Link table"
+                   (Dutch  , InternalPlug   BinSQL{})    -> "Koppel tabel"
+                   (English, InternalPlug   ScalarSQL{}) -> "Enumeration tabel"
+                   (Dutch  , InternalPlug   ScalarSQL{}) -> "Toegestane waarden tabel"
+                )
+       ] 
+    showDetailsOfFunction :: Interface -> [Cell]
+    showDetailsOfFunction ifc =
+       [ emptyCell
+       , (string.name.ifcObj) ifc
+       , string (showLang lang (fpa ifc))
+       , (number.fromIntegral.fPoints) ifc
+       ]
+    
+pimpWs :: Worksheet -> Worksheet
+pimpWs ws = ws{worksheetTable = fmap pimpWsT (worksheetTable ws)
+              }
+pimpWsT :: Table -> Table
+pimpWsT t = t{tableColumns = map (\c -> c{columnAutoFitWidth = Just AutoFitWidth}) 
+                              (tableColumns t ++ replicate (maximum (map (length.rowCells) (tableRows t))) emptyColumn)
+             ,tableRows = map pimpRow (tableRows t)
+             }
+pimpRow :: Row -> Row
+pimpRow r = r{rowAutoFitHeight = Just AutoFitHeight}
+ src/lib/DatabaseDesign/Ampersand/Output/Fspec2Pandoc.hs view
@@ -0,0 +1,107 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ScopedTypeVariables #-}+module DatabaseDesign.Ampersand.Output.Fspec2Pandoc (fSpec2Pandoc)+where+import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters+import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterInterfaces         (chpInterfacesBlocks, chpInterfacesPics)+import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterIntroduction       (chpIntroduction)+import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterNatLangReqs        (chpNatLangReqs)+import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDiagnosis          (chpDiagnosis)+import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterConceptualAnalysis (chpConceptualAnalysis)+import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterProcessAnalysis    (chpProcessAnalysis)+import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterECArules           (chpECArules)+import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDataAnalysis       (chpDataAnalysis)+import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterSoftwareMetrics    (fpAnalysis)+import DatabaseDesign.Ampersand.Output.ToPandoc.ChapterGlossary           (chpGlossary)+import Data.Time.Format (formatTime)+import Data.List (nub)+--import Debug.Trace+--DESCR ->+--The functional specification starts with an introduction+--The second chapter defines the functionality of the system for stakeholders.+--Because we assume these stakeholders to speak the language of the primary process without any technical knowledge,+--the second chapter contains natural language only. +--The third chapter is intended for the analyst. It contains all the rules mentioned in+--natural language in the second chapter. It presents the trace from natural language+--to the formal rule.+--The fourth chapter presents a datamodel together with all the multiplicity rules.+-- by datasets and rules.+--Datasets are specified through PLUGS in Ampersand. The dataset is build around one concept, +--also called the theme. Functionalities defined on the theme by one or more plugs are+--described together with the rules that apply to the dataset. Rules not described by+--the dataset are described in the last section of chapter 2.+--The following chapters each present a INTERFACE+--The specification end with a glossary.+++++--TODO: Invent a syntax for meta information that is included in the source file...++--The following general requirements apply to the functional specification document:+--Descriptive title, number, identifier, etc. of the specification+--Date of last effective revision and revision designation+--A logo (trademark recommended) to declare the document copyright, ownership and origin+--Table of Contents+--Person, office, or agency responsible for questions on the specification, updates, and deviations.+--The significance, scope or importance of the specification and its intended use.+--Terminology, definitions and abbreviations to clarify the meanings of the specification+--Test methods for measuring all specified characteristics+--Material requirements: physical, mechanical, electrical, chemical, etc. Targets and tolerances.+--Performance testing requirements. Targets and tolerances.+--Drawings, photographs, or technical illustrations+--Workmanship+--Certifications required.+--Safety considerations and requirements+--Environmental considerations and requirements+--Quality control requirements, Sampling (statistics), inspections, acceptance criteria+--Person, office, or agency responsible for enforcement of the specification.+--Completion and delivery.+--Provisions for rejection, reinspection, rehearing, corrective measures+--References and citations for which any instructions in the content maybe required to fulfill the traceability and clarity of the document+--Signatures of approval, if necessary+--Change record to summarize the chronological development, revision and completion if the document is to be circulated internally+--Annexes and Appendices that are expand details, add clarification, or offer options.++fSpec2Pandoc :: Fspc -> Options -> (Pandoc, [Picture])+fSpec2Pandoc fSpec flags = ( myDoc , concat picturesByChapter )+  where +    myDoc = +      ( (setTitle  +           (text+             (case (language flags, diagnosisOnly flags) of+               (Dutch  , False) -> "Functionele Specificatie van "+               (English, False) -> "Functional Specification of "+               (Dutch  ,  True) -> "Diagnose van "+               (English,  True) -> "Diagnosis of "+             )+            <>+            (singleQuoted.text.name) fSpec+           )+        )+      . (setAuthors (case metaValues "authors" fSpec of+                [] -> case language flags of+                        Dutch   -> [text "Specificeer auteurs in ADL met: META \"authors\" \"<auteursnamen>\""]+                        English -> [text "Specify authors in ADL with: META \"authors\" \"<author names>\""]+                xs -> map text (nub xs))  --reduce doubles, for when multiple script files are included, this could cause authors to be mentioned several times.+        )+      . (setDate (text (formatTime (lclForLang flags) "%-d %B %Y" (genTime flags))))+      ) +      (doc (foldr (<>) mempty docContents))+    docContents :: [Blocks]+    picturesByChapter :: [[Picture]]+    (docContents, picturesByChapter) = unzip [fspec2Blocks chp | chp<-chaptersInDoc flags]++    fspec2Blocks :: Chapter -> (Blocks, [Picture])+    fspec2Blocks Intro              = (chpIntroduction        fSpec flags, [])+    fspec2Blocks SharedLang         = (chpNatLangReqs       0 fSpec flags, [])+    fspec2Blocks Diagnosis          = chpDiagnosis            fSpec flags+    fspec2Blocks ConceptualAnalysis = chpConceptualAnalysis 0 fSpec flags+    fspec2Blocks ProcessAnalysis    = chpProcessAnalysis    0 fSpec flags+    fspec2Blocks DataAnalysis       = chpDataAnalysis         fSpec flags +    fspec2Blocks SoftwareMetrics    = (fpAnalysis             fSpec flags, [])+    fspec2Blocks EcaRules           = (chpECArules            fSpec flags, [])+    fspec2Blocks Interfaces         = (chpInterfacesBlocks  0 fSpec flags, chpInterfacesPics fSpec flags)+    fspec2Blocks Glossary           = (chpGlossary          0 fSpec flags, [])+    +
+ src/lib/DatabaseDesign/Ampersand/Output/PandocAux.hs view
@@ -0,0 +1,660 @@+{-# OPTIONS_GHC -Wall #-}+module DatabaseDesign.Ampersand.Output.PandocAux+      ( writepandoc+      , labeledThing+      , symDefLabel, symDefRef+      , symReqLabel, symReqRef, symReqPageRef+      , xrefSupported+      , pandocEqnArray+      , pandocEqnArrayOnelabel+      , pandocEquation+      , makeDefinition, uniquecds+      , count+      , ShowMath(..)+      , latexEscShw, escapeNonAlphaNum+      , xrefCitation+      , texOnly_Id+      , texOnly_fun+      , texOnly_rel+      , commaEngPandoc, commaNLPandoc+      )+where+import DatabaseDesign.Ampersand.ADL1+import DatabaseDesign.Ampersand.Fspec+import Data.Char hiding (Space)+import Text.Pandoc+import Text.Pandoc.Builder+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree+import DatabaseDesign.Ampersand.Basics hiding (hPutStrLn)+import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)+import DatabaseDesign.Ampersand.Misc        +import System.Process      (system)+import System.Exit         (ExitCode(ExitSuccess,ExitFailure))+import System.IO              (hPutStrLn, stderr)+import Paths_ampersand+import System.FilePath       -- (combine,addExtension,replaceExtension)+import System.Directory+import System.Info (os)+import Data.Monoid+import Data.List              (isInfixOf,intercalate)+import Control.Monad+import Data.Maybe++fatal :: Int -> String -> a+fatal = fatalMsg "Output.PandocAux"+++-- | Default key-value pairs for use with the Pandoc template+defaultWriterVariables :: Options -> Fspc -> [(String , String)]+defaultWriterVariables flags fSpec+  = [ ("title", (case (language flags, diagnosisOnly flags) of+                        (Dutch  , False) -> "Functionele Specificatie van "+                        (English, False) -> "Functional Specification of "+                        (Dutch  ,  True) -> "Diagnose van "+                        (English,  True) -> "Diagnosis of " +                )++name fSpec)+ --   , ("mainfont",+ --   , ("sansfont",+ --   , ("monofont",+ --   , ("mathfont",+    , ("fontsize", "10pt,a4paper")   --can be overridden by geometry package (see below)+    , ("lang"    , case language flags of+                       Dutch   -> "dutch"+                       English -> "english")+    , ("mainlang", case language flags of+                       Dutch   -> "dutch"+                       English -> "english")+    , ("documentclass","report")+    ] +++    [ ("toc" , "<<TheTableOfContentsShouldGoHere>>") | not (diagnosisOnly flags)]+++    [ ("header-includes", unlines +         [ "% ============Ampersand specific Begin================="+         , "\\usepackage[toc]{glossaries}    % package used to define terms"+         , "\\makeglossaries"+         , "\\usepackage{breqn}"+         , "\\usepackage{colonequals}"+         , "% == [all]{hypcap} after {hyperref} shows the ref'd picture i.o. the caption @ click =="+         , "\\usepackage[all]{hypcap}"+         , "\\def\\id#1{\\mbox{\\em #1\\/}}"+         , "\\newcommand{\\marge}[1]{\\marginpar{\\begin{minipage}[t]{3cm}{\\noindent\\small\\em #1}\\end{minipage}}}"+         , "\\def\\define#1{\\label{dfn:#1}\\index{#1}{\\em #1}}"+         , "\\def\\defmar#1{\\label{dfn:#1}\\index{#1}\\marge{#1}{\\em #1}}"+         , "\\newcommand{\\iden}{\\mathbb{I}}"+         , "\\newcommand{\\ident}[1]{\\mathbb{I}_{#1}}"+         , "\\newcommand{\\full}{\\mathbb{V}}"+         , "\\newcommand{\\fullt}[1]{\\mathbb{V}_{[#1]}}"+         , "\\newcommand{\\flip}[1]{{#1}^\\smallsmile} %formerly:  {#1}^\\backsim"+         , "\\newcommand{\\kleeneplus}[1]{{#1}^{+}}"+         , "\\newcommand{\\kleenestar}[1]{{#1}^{*}}"+         , "\\newcommand{\\asterisk}{*}"+         , "\\newcommand{\\cmpl}[1]{\\overline{#1}}"+         , "\\newcommand{\\subs}{\\vdash}"+         , "\\newcommand{\\rel}{\\times}"+         , "\\newcommand{\\fun}{\\rightarrow}"+         , "\\newcommand{\\isa}{\\sqsubseteq}"+         , "\\newcommand{\\N}{\\mbox{\\msb N}}"+         , "\\newcommand{\\disjn}[1]{\\id{disjoint}(#1)}"+         , "\\newcommand{\\fsignat}[3]{\\id{#1}:\\id{#2}\\fun\\id{#3}}"+         , "\\newcommand{\\signat}[3]{\\id{#1}:\\id{#2}\\rel\\id{#3}}"+         , "\\newcommand{\\signt}[2]{\\mbox{\\({#1}_{[{#2}]}\\)}}"+         , "\\newcommand{\\declare}[3]{\\id{#1}:\\ \\id{#2}\\rel\\id{#3}}"+         , "\\newcommand{\\fdeclare}[3]{\\id{#1}:\\ \\id{#2}\\fun\\id{#3}}"+         , "% ============Ampersand specific End==================="+         ])+--    , ("geometry", "margin=2cm, a4paper")+    ]+         +     +--DESCR -> functions to write the pandoc+--         String = the name of the outputfile+--         The first IO() is a Pandoc output format+--         The second IO(): If the output format is latex, then this IO() generates a .pdf from the .tex+writepandoc :: Options -> Fspc -> Pandoc -> (String,IO(),IO())+writepandoc flags fSpec thePandoc = (outputFile,makeOutput,postProcessMonad)+         where+         outputFile = addExtension (combine (dirOutput flags) (baseName flags)) +                                       (case fspecFormat flags of        +                                                 Fasciidoc     -> ".txt"+                                                 Fcontext      -> ".context"+                                                 Fdocbook      -> ".docbook"+                                                 Fman          -> ".man"+                                                 Fmarkdown     -> ".md"+                                                 Fmediawiki    -> ".mediawiki"+                                                 Forg          -> ".org"+                                                 Fplain        -> ".plain"+                                                 Frst          -> ".rst"+                                                 FPandoc       -> ".pandoc"+                                                 Frtf          -> ".rtf"+                                                 FLatex        -> ".tex"+                                                 Fhtml         -> ".html"+                                                 Fopendocument -> ".odt"+                                                 Ftexinfo      -> ".texinfo"+                                                 Ftextile      -> ".textile"+                                       )+         makeOutput+            =  do template <- readDefaultTemplate fSpecFormatString+                  verboseLn flags ("Generating "++fSpecFormatString++" to : "++outputFile)+                  writeFile outputFile (pandocWriter (writerOptions template) thePandoc)+                  verboseLn flags "Variables to set in the template:"+                  verboseLn flags (intercalate "\n   " (map show (writerVariables (writerOptions template))))+                  verboseLn flags "... done."+           where +              pandocWriter :: WriterOptions -> Pandoc -> String+              pandocWriter =+                case fspecFormat flags of+                  Fasciidoc -> fatal 145 "No current support for asciidoc" +                  FPandoc   -> writeNative +                  Fcontext  -> writeConTeXt+                  Fdocbook  -> writeDocbook +                  Fhtml     -> writeHtmlString+                  FLatex    -> writeLaTeX+                  Fman      -> writeMan+                  Fmarkdown -> writeMarkdown +                  Fmediawiki -> writeMediaWiki +                  Fopendocument -> writeOpenDocument+                  Forg -> writeOrg+                  Fplain -> writePlain+                  Frst -> writeRST+                  Frtf -> writeRTF+                  Ftexinfo -> writeTexinfo+                  Ftextile -> writeTextile+              fSpecFormatString :: String+              fSpecFormatString =+                case fspecFormat flags of+                  FPandoc   -> "pandoc"+                  Fasciidoc -> "asciidoc"+                  Fcontext  -> "context"+                  Fdocbook  -> "docbook"+                  Fhtml     -> "html"+                  FLatex    -> "latex"+                  Fman      -> "man"+                  Fmarkdown -> "markdown"+                  Fmediawiki -> "mediawiki"+                  Fopendocument -> "opendocument"+                  Forg -> "org"+                  Fplain -> "plain"+                  Frst -> "rst"+                  Frtf -> "rtf"+                  Ftexinfo -> "texinfo"+                  Ftextile -> "textile"                  +              readDefaultTemplate :: String -> IO(Maybe String)+              readDefaultTemplate  s = +                do { dataDir <- getDataDir+                   ; let fp = dataDir </> "outputTemplates" </> "default."++s+                   ; exists <- doesFileExist fp+                   ; (if exists +                      then do contents <- readFile fp+                              return $ Just contents +                      else do verboseLn flags $ "Template file does not exist: "++fp+                              verboseLn flags "...trying without template...(but you might want to reinstall ampersand...)" +                              return Nothing +                     )+                   } +              writerOptions :: Maybe String -> WriterOptions+              writerOptions template = case theme flags of+                          ProofTheme -> ampersandDefaultWriterOptions +                                           { writerTableOfContents=False+                                           , writerNumberSections=False+                                           }+                          _          -> ampersandDefaultWriterOptions+                     where+                       ampersandDefaultWriterOptions =+                         def+                            { writerStandalone=isJust template+                            , writerTableOfContents=True+                            , writerNumberSections=True+                            , writerTemplate=fromMaybe "" template+                            , writerVariables=defaultWriterVariables flags fSpec}+         postProcessMonad :: IO()+         postProcessMonad = +           case fspecFormat flags of   +               FLatex  -> do +                          (ready,nrOfRounds) <- doRestOfPdfLatex (False, 0)  -- initialize with: (<NotReady>, <0 rounds so far>)+                          verboseLn flags ("PdfLatex was called "+++                                          (if nrOfRounds>1 then show nrOfRounds++" times" else "once")+++                                          if ready then "."+                                                   else ", but did not solve all references!")+                             where +                                doRestOfPdfLatex :: (Bool,Int) -> IO (Bool,Int)+                                doRestOfPdfLatex (ready, roundsSoFar)+                                  = if ready || roundsSoFar > 4    -- Make sure we will not hit a loop when something is wrong with call to pdfLatex ...+                                    then return (ready, roundsSoFar)+                                    else do callPdfLatexOnce+                                            let needle = "Rerun to get cross-references right." -- This is the text of the LaTeX Warning telling that label(s) may have changed. +                                            {- The log file should be renamed before reading, because readFile opens the file+                                               for lazy IO. In a next run, pdfLatex will try to write to the log file again. If it+                                               was read using readFile, it will fail because the file is still open. 8-((  +                                            -} +                                            renameFile (replaceExtension outputFile "log") (replaceExtension outputFile ("log"++show roundsSoFar))+                                            haystack <- readFile (replaceExtension outputFile ("log"++show roundsSoFar))  +                                            let notReady =  needle `isInfixOf` haystack+                                            when notReady (verboseLn flags "Another round of pdfLatex is required. Hang on...")+                                          --  when notReady (dump "log")  -- Need to dump the last log file, otherwise pdfLatex cannot write its log.+                                            doRestOfPdfLatex (not notReady, roundsSoFar +1)++                                callPdfLatexOnce :: IO ()+                                callPdfLatexOnce = +                                   do result <- if os `elem` ["mingw32","mingw64","cygwin","windows"] --REMARK: not a clear enum to check for windows OS+                                                then system ( pdfLatexCommand+++                                                              if verboseP flags then "" else "> "++combine (dirOutput flags) "pdflog" ) >>+                                                     system  makeIndexCommand+                                                --REMARK: MikTex is windows; Tex-live does not have the flag -include-directory.+                                                else system ( "cd "++dirOutput flags+++                                                              " && pdflatex "++commonFlags+++                                                              texFilename ++ if verboseP flags then "" else "> "++addExtension(baseName flags) ".pdflog" ) >>+                                                     system makeIndexCommand+                                      case result of +                                         ExitSuccess   -> verboseLn flags "PDF file created."+                                         ExitFailure _ -> hPutStrLn stderr $  if verboseP flags +                                                                              then "" -- in verbose mode, Latex already gave plenty of information+                                                                              else "\nLatex error.\nFor more information, run pdflatex on "++texFilename+++                                                                                    " or rerun ampersand with the --verbose option"+                                      where+                                      pdfLatexCommand = "pdflatex "++commonFlags++pdfflags++ outputFile+                                      --makeIndexCommand = "makeglossaries "++replaceExtension outputFile "glo"+                                      --makeindex uses the error stream for verbose stuff...+                                      makeIndexCommand = "makeindex -s "++replaceExtension outputFile "ist"++" -t "++replaceExtension outputFile "glg"++" -o "++replaceExtension outputFile "gls"++" "++replaceExtension outputFile "glo 2> "++combine (dirOutput flags) "glossaries.log"+                                      pdfflags = (if verboseP flags then "" else " --disable-installer") +++                                                 " -include-directory="++dirOutput flags++ " -output-directory="++dirOutput flags++" "+                                      texFilename = addExtension (baseName flags) ".tex"+                                      commonFlags = if verboseP flags then "" else "--interaction=nonstopmode " -- MacTex options are normally with one '-', but '--interaction' is accepted +                                      -- when verbose is off, let latex halt on error to prevent waiting for user input without prompting for it+                                      -- on windows, we also do --disable-installer, since otherwise a missing package may cause interaction,+                                      -- even with --interaction=nonstopmode.+               _  -> return()            ++-----Linguistic goodies--------------------------------------++count :: Options -> Int -> String -> String+count flags n x+ = case (language flags, n) of+      (Dutch  , 0) -> "geen "++plural Dutch x+      (Dutch  , 1) -> "één "++x+      (Dutch  , 2) -> "twee "++plural Dutch x+      (Dutch  , 3) -> "drie "++plural Dutch x+      (Dutch  , 4) -> "vier "++plural Dutch x+      (Dutch  , 5) -> "vijf "++plural Dutch x+      (Dutch  , 6) -> "zes "++plural Dutch x+      (Dutch  , _) -> show n++" "++plural Dutch x+      (English, 0) -> "no "++plural English x+      (English, 1) -> "one "++x+      (English, 2) -> "two "++plural English x+      (English, 3) -> "three "++plural English x+      (English, 4) -> "four "++plural English x+      (English, 5) -> "five "++plural English x+      (English, 6) -> "six "++plural English x+      (English, _) -> show n++" "++plural English x+    +      +------ Symbolic referencing ---------------------------------++class SymRef a where+  symLabel :: a -> String -- unique label for symbolic reference purposes+  symReqLabel :: a -> String  -- labels the requirement of a+  symReqLabel   c = "\\label{Req"++symLabel c++"}"+  symDefLabel :: a -> String  -- labels the definition of a+  symDefLabel   c = "\\label{Def"++symLabel c++"}"+  symReqRef :: a -> String  -- references the requirement of a+  symReqRef     c = "\\ref{Req"++symLabel c++"}"+  symDefRef :: a -> String  -- references the definition of a +  symDefRef     c = "\\ref{Def"++symLabel c++"}"+  symReqPageRef :: a -> String  -- references the requirement of a+  symReqPageRef c = "\\pageref{Req"++symLabel c++"}"+  symDefPageRef :: a -> String  -- references the definition of a +  symDefPageRef c = "\\pageref{Def"++symLabel c++"}"++instance SymRef ConceptDef where+  symLabel cd = "Concept:"++escapeNonAlphaNum (cdcpt cd)++instance SymRef A_Concept where+  symLabel c = "Concept:"++escapeNonAlphaNum (name c)++instance SymRef Declaration where+  symLabel d = "Decl:"++escapeNonAlphaNum (name d++name (source d)++name (target d))++instance SymRef Rule where+  symLabel r = "Rule:"++escapeNonAlphaNum (name r)++instance SymRef PlugInfo where+  symLabel p = "PlugInfo "++escapeNonAlphaNum (name p)++--   xrefChptReference :: String -> [Inline]+--   xrefChptReference myLabel = [RawInline (Text.Pandoc.Builder.Format "latex") ("\\ref{section:"++myLabel++"}")] --TODO werkt nog niet correct+---   xrefTableReference :: String -> [Inline]+--   xrefTableReference myLabel = [RawInline (Text.Pandoc.Builder.Format "latex") ("\\ref{tab:"++myLabel++"}")]+-- BECAUSE: Why (SJ) does the code of labeledHeader look stupid?+--         When Han looked at pandoc code TexInfo.hs blockToTexinfo ln.208,+--         he expected chapter,section,sub,subsub respectively.+--         However, he got section,sub,subsub,plain text respectively.+--         Looks like an error in PanDoc, doesn't it?+--         So now he wrote chapters as 0 setting a [Inline] -> [RawInline (Text.Pandoc.Builder.Format "latex") "\\chapter{...}"].+--         We do not know yet how this relates to other formats like rtf.++-- TODO: Fix the other labeled 'things', to make a neat reference.+labeledThing :: Options -> Int -> String -> String -> Blocks+labeledThing flags lev lbl t =+    header (lev+1) +       ((text t <> xrefLabel flags lbl))  + +-- | A label that can be cross referenced to. (only for output formats that support this feature)+xrefLabel :: Options -> String -> Inlines        -- uitbreidbaar voor andere rendering dan LaTeX+xrefLabel flags myLabel+   = if xrefSupported flags+     then rawInline "latex" ("\\label{"++escapeNonAlphaNum myLabel++"}")+     else mempty -- fatal 508 "Illegal use of xrefLabel."+xrefSupported :: Options -> Bool+xrefSupported flags = fspecFormat flags `elem` [FLatex] +xrefCitation :: String -> Inline    -- uitbreidbaar voor andere rendering dan LaTeX+xrefCitation myLabel = RawInline (Text.Pandoc.Builder.Format "latex") ("\\cite{"++escapeNonAlphaNum myLabel++"}")+++-- Para [Math DisplayMath "\\id{aap}=A\\times B\\\\\n\\id{noot}=A\\times B\n"]+pandocEqnArray :: [(String,String,String)] -> [Block]+pandocEqnArray xs+ = [ Para [ RawInline (Text.Pandoc.Builder.Format "latex") ("\\begin{eqnarray}\n   "+++                               intercalate "\\\\\n   " [ a++"&"++b++"&"++c | (a,b,c)<-xs ]+++                               "\n\\end{eqnarray}") ]+   | not (null xs)]+   +pandocEqnArrayOnelabel :: String -> [(String,String,String)] -> [Block]+pandocEqnArrayOnelabel label xs+ = case xs of+    []           -> []+    (a,b,c):rest -> [ Para [ RawInline (Text.Pandoc.Builder.Format "latex") ("\\begin{eqnarray}\n   "++a++"&"++b++"&"++c++label++"\\\\\n   "+++                               intercalate "\\nonumber\\\\\n   " [ l++"&"++m++"&"++r | (l,m,r)<-rest ]+++                               "\\nonumber\n\\end{eqnarray}")+                    ]      ]+   +pandocEquation :: String -> [Block]+pandocEquation x+ = [ Para [ RawInline (Text.Pandoc.Builder.Format "latex") ("\\begin{equation}\n   "++ x ++"\n\\end{equation}") ]+   | not (null x)]++--DESCR -> pandoc print functions for Ampersand data structures+---------------------------------------+-- LaTeX math markup+---------------------------------------++class ShowMath a where+ showMath :: a -> String++instance ShowMath A_Concept where+ showMath c = texOnly_Id (name c)++instance ShowMath A_Gen where+ showMath g@Isa{} = showMath (genspc g)++"\\ \\le\\ "++showMath (gengen g)+ showMath g@IsE{} = showMath (genspc g)++"\\ =\\ "++intercalate "\\cap" (map showMath (genrhs g))++instance ShowMath Rule where+ showMath r = showMath (rrexp r)++instance ShowMath Sign where+ showMath (Sign s t) = showMath s++"\\rel"++showMath t++instance ShowMath Expression where+ showMath = showExpr . insParentheses+   where  showExpr (EEqu (l,r)) = showExpr l++texOnly_equals++showExpr r+          showExpr (EImp (l,r)) = showExpr l++texOnly_subs++showExpr r+          showExpr (EIsc (l,r)) = showExpr l++texOnly_inter++showExpr r+          showExpr (EUni (l,r)) = showExpr l++texOnly_union++showExpr r+          showExpr (EDif (l,r)) = showExpr l++texOnly_bx ++showExpr r+          showExpr (ELrs (l,r)) = showExpr l++texOnly_lRes++showExpr r+          showExpr (ERrs (l,r)) = showExpr l++texOnly_rRes++showExpr r+          showExpr (ECps (l,r)) = showExpr l++texOnly_compose++showExpr r+          showExpr (ERad (l,r)) = showExpr l++texOnly_relAdd++showExpr r+          showExpr (EPrd (l,r)) = showExpr l++texOnly_crtPrd++showExpr r+          showExpr (EKl0 e)     = showExpr (addParensToSuper e)++"^{"++texOnly_star++"}"+          showExpr (EKl1 e)     = showExpr (addParensToSuper e)++"^{"++texOnly_plus++"}"+          showExpr (EFlp e)     = showExpr (addParensToSuper e)++"^{"++texOnly_flip++"}"+          showExpr (ECpl e)     = "\\cmpl{"++showExpr e++"}"+          showExpr (EBrk e)     = "("++showExpr e++")"+          showExpr (EDcD d)     = "\\id{"++name d++"}"+          showExpr (EDcI c)     = "I_{\\id{"++name c++"}}"+          showExpr  EEps{}      = ""+          showExpr (EDcV sgn)   = "V_{\\id{"++show (source sgn)++"}\times\\id{"++show (target sgn)++"}}"+          showExpr (EMp1 a _)   = "'{\tt "++a++"}'"++-- add extra parentheses to consecutive superscripts, since latex cannot handle these+-- (this is not implemented in insParentheses because it is a latex-specific issue)+addParensToSuper :: Expression -> Expression+addParensToSuper e@EKl0{} = EBrk e+addParensToSuper e@EKl1{} = EBrk e+addParensToSuper e@EFlp{} = EBrk e+addParensToSuper e        = e++instance ShowMath Declaration where+ showMath decl@(Sgn{})+  = "\\declare{"++latexEscShw(name decl)++"}{"++latexEscShw(name (source decl))++"}{"++latexEscShw(name (target decl))++"}"+ showMath Isn{}+  = "\\mathbb{I}"+ showMath Vs{}+  = "\\full"++-- | latexEscShw escapes to LaTeX encoding. It is intended to be used in LaTeX text mode.+--   For more elaborate info on LaTeX encoding, consult the The Comprehensive LATEX Symbol List+--   on:    http://ftp.snt.utwente.nl/pub/software/tex/info/symbols/comprehensive/symbols-a4.pdf+latexEscShw :: String -> String+latexEscShw ""           = ""+latexEscShw ('\"':c:cs) | isAlphaNum c = "``"++latexEscShw (c:cs)+                        | otherwise    = "''"++latexEscShw (c:cs)+latexEscShw "\""        = "''"+latexEscShw (c:cs)      | isAlphaNum c && isAscii c = c:latexEscShw cs+                        | otherwise    = f c++latexEscShw cs+ where+  f '"' = "\\textquotedbl "+  f '#' = "\\#"+  f '$' = "\\$"+  f '%' = "\\%"+  f '&' = "\\&"+  f '\\'= "\\textbackslash "+  f '^' = "\\^{}"+  f '_' = "\\_"+  f '{' = "\\{"+  f '|' = "\\textbar "+  f '}' = "\\}"+  f '~' = "\\~{}"+  f '¦' = "\\textbrokenbar "+  f '¨' = "\\textasciidieresis "+  f '¯' = "\\textasciimacron "+  f '´' = "\\textasciiacute "+  f '¢' = "\\textcent "+  f '£' = "\\textpound "+  f '¤' = "\\textcurrency "+  f '¥' = "\\textyen "+  f '€' = "\\texteuro "+  f '<' = "\\textless "+  f '>' = "\\textgreater "+  f '±' = "\\textpm "+  f '«' = "\\guillemotleft "+  f '»' = "\\guillemotright "+  f '×' = "\\texttimes "+  f '÷' = "\\textdiv "+  f '§' = "\\S "+  f '©' = "\\textcopyright "+  f '¬' = "\\textlnot "+  f '®' = "\\textregistered "+  f '°' = "\\textdegree "+  f 'µ' = "\\textmu "+  f '¶' = "\\P "+  f '·' = "\\textperiodcentered "+  f '¼' = "\\textonequarter "+  f '½' = "\\textonehalf "+  f '¾' = "\\textthreequarters "+  f '¹' = "\\textonesuperior "+  f '²' = "\\texttwosuperior "+  f '³' = "\\textthreesuperior "+  f '∞' = "\\hbipropto "+  f 'ä' = "\\\"{a}"        --  umlaut or dieresis+  f 'Ä' = "\\\"{A}"        --  umlaut or dieresis+  f 'â' = "\\^{a}"         --  circumflex+  f 'Â' = "\\^{A}"         --  circumflex+  f 'à' = "\\`{a}"         --  grave accent+  f 'À' = "\\`{A}"         --  grave accent+  f 'á' = "\\'{a}"         --  acute accent+  f 'Á' = "\\'{A}"         --  acute accent+  f 'ã' = "\\~{a}"         --  tilde+  f 'Ã' = "\\~{A}"         --  tilde+  f 'å' = "\\aa "+--  f 'å' = "\\r{a}"       --  alternatively: ring over the letter+  f 'Å' = "\\AA "+--  f 'Å' = "\\r{A}"       --  alternatively: ring over the letter+  f 'ą' = "\\k{a}"         --  ogonek+  f 'Ą' = "\\k{A}"         --  ogonek+  f 'ª' = "\\textordfeminine "+  f 'æ' = "\\ae "+  f 'Æ' = "\\AE "+  f 'ç' = "\\c{c}"         --  cedilla+  f 'Ç' = "\\c{C}"         --  cedilla+  f 'Ð' = "\\DH "+  f 'ð' = "\\dh "+  f 'ë' = "\\\"{e}"        --  umlaut or dieresis+  f 'Ë' = "\\\"{E}"        --  umlaut or dieresis+  f 'ê' = "\\^{e}"         --  circumflex+  f 'Ê' = "\\^{E}"         --  circumflex+  f 'è' = "\\`{e}"         --  grave accent+  f 'È' = "\\`{E}"         --  grave accent+  f 'é' = "\\'{e}"         --  acute accent+  f 'É' = "\\'{E}"         --  acute accent+  f 'ï' = "\\\"{\\i}"      --  umlaut or dieresis+  f 'Ï' = "\\\"{I}"        --  umlaut or dieresis+  f 'î' = "\\^{\\i}"       --  circumflex+  f 'Î' = "\\^{I}"         --  circumflex+  f 'ì' = "\\`{\\i}"       --  grave accent+  f 'Ì' = "\\`{I}"         --  grave accent+  f 'í' = "\\'{\\i}"       --  acute accent+  f 'Í' = "\\'{I}"         --  acute accent+  f 'ł' = "\\l "           --  l with stroke+  f 'Ł' = "\\L "           --  l with stroke+  f 'n' = "\\~{n}"         --  tilde+  f 'Ñ' = "\\~{N}"         --  tilde+  f 'Ȯ' = "\\.{O}"         --  dot over the letter+  f 'ȯ' = "\\.{o}"         --  dot over the letter +  f 'ö' = "\\\"{o}"        --  umlaut or dieresis+  f 'Ö' = "\\\"{O}"        --  umlaut or dieresis+  f 'ô' = "\\^{o}"         --  circumflex+  f 'Ô' = "\\^{O}"         --  circumflex+  f 'ò' = "\\`{o}"         --  grave accent+  f 'Ò' = "\\`{O}"         --  grave accent+  f 'ó' = "\\'{o}"         --  acute accent+  f 'Ó' = "\\'{O}"         --  acute accent+  f 'õ' = "\\~{o}"         --  tilde+  f 'Õ' = "\\~{O}"         --  tilde+  f 'ō' = "\\={o}"         --  macron accent a bar over the letter)+  f 'Ō' = "\\={O}"         --  macron accent a bar over the letter)+  f 'ő' = "\\H{o}"         --  long Hungarian umlaut double acute)+  f 'Ő' = "\\H{O}"         --  long Hungarian umlaut double acute)+  f 'Ø' = "\\O "+  f 'ø' = "\\o "+  f 'º' = "\\textordmasculine "+  f 'ŏ' = "\\u{o}"         --  breve over the letter+  f 'Ŏ' = "\\u{O}"         --  breve over the letter+  f 'œ' = "\\oe "+  f 'Œ' = "\\OE "+  f 'š' = "\\v{s}"         --  caron/hacek "v") over the letter+  f 'Š' = "\\v{S}"         --  caron/hacek "v") over the letter+  f 'ß' = "\\ss "+  f 'Þ' = "\\TH "+  f 'þ' = "\\th "+  f '™' = "\\texttrademark "+  f 'ü' = "\\\"{u}"        --  umlaut or dieresis+  f 'Ü' = "\\\"{U}"        --  umlaut or dieresis+  f 'û' = "\\^{u}"         --  circumflex+  f 'Û' = "\\^{U}"         --  circumflex+  f 'ù' = "\\`{u}"         --  grave accent+  f 'Ù' = "\\`{U}"         --  grave accent+  f 'ú' = "\\'{u}"         --  acute accent+  f 'Ú' = "\\'{U}"         --  acute accent+  f 'ý' = "\\'{y}"         --  acute accent+  f 'Ý' = "\\'{Y}"         --  acute accent+  f _   = [c] -- let us think if this should be:    fatal 661 ("Symbol "++show x++" (character "++show (ord c)++") is not supported")+             ++--posixFilePath :: FilePath -> String+-- tex uses posix file notation, however when on a windows machine, we have windows conventions for file paths...+-- To set the graphicspath, we want something like: \graphicspath{{"c:/data/ADL/output/"}}+--posixFilePath fp = "/"++System.FilePath.Posix.addTrailingPathSeparator (System.FilePath.Posix.joinPath   (tail  (splitDirectories fp)))++uniquecds :: A_Concept -> [(String,ConceptDef)]+uniquecds c = [(if length(cptdf c)==1 then cdcpt cd else cdcpt cd++show i , cd) | (i,cd)<-zip [(1::Integer)..] (cptdf c)]++makeDefinition :: Options -> Int -> String -> String -> String -> String -> [Block]+makeDefinition flags i nm lbl defin ref =+  case fspecFormat flags of+    FLatex ->  [ Para ( [ RawInline (Text.Pandoc.Builder.Format "latex") $ "\\newglossaryentry{"++escapeNonAlphaNum nm ++"}{name={"++latexEscShw nm ++"}, description={"++latexEscShw defin++"}}\n"] +++                        [ RawInline (Text.Pandoc.Builder.Format "latex") $ lbl ++ "\n" | i == 0] +++                        [ RawInline (Text.Pandoc.Builder.Format "latex") $ insertAfterFirstWord refStr defStr] +++                        [ RawInline (Text.Pandoc.Builder.Format "latex") (latexEscShw (" ["++ref++"]")) | not (null ref) ]+                      )+               ]+    _      ->  [ Para ( Str defin : [ Str (" ["++ref++"]") | not (null ref) ] )+               ]+ where refStr = "\\marge{\\gls{"++escapeNonAlphaNum nm++"}}" +       defStr = latexEscShw defin+       -- by putting the ref after the first word of the definition, it aligns nicely with the definition+       insertAfterFirstWord s wordsStr = let (fstWord, rest) = break (==' ') wordsStr+                                         in  fstWord ++ s ++ rest+ +commaEngPandoc :: Inline -> [Inline] -> [Inline]+commaEngPandoc s [a,b,c]= [a,Str ", ",b,Str ", ",s, Str " ", c]+commaEngPandoc s [a,b]  = [a,Str " ",s, Str " ", b]+commaEngPandoc _   [a]    = [a]+commaEngPandoc s (a:as) = [a, Str ", "]++commaEngPandoc s as+commaEngPandoc _   []     = []++commaNLPandoc :: Inline -> [Inline] -> [Inline]+commaNLPandoc s [a,b]  = [a,Str " ",s, Str " ", b]+commaNLPandoc  _  [a]    = [a]+commaNLPandoc s (a:as) = [a, Str ", "]++commaNLPandoc s as+commaNLPandoc  _  []     = []++---------------------------+--- LaTeX related stuff ---+---------------------------++texOnly_Id :: String -> String+texOnly_Id s = "\\id{"++latexEscShw s++"} "++texOnly_fun :: String+texOnly_fun = "\\rightarrow "++texOnly_rel :: String+texOnly_rel = "\\times "++texOnly_compose :: String+texOnly_compose = ";"++texOnly_relAdd :: String+texOnly_relAdd = "\\dagger "++texOnly_crtPrd :: String+texOnly_crtPrd = "\\asterisk "++texOnly_inter :: String+texOnly_inter = "\\cap "++texOnly_union :: String+texOnly_union = "\\cup "++texOnly_subs :: String+texOnly_subs = "\\vdash "++texOnly_equals :: String+texOnly_equals = "="++texOnly_star :: String+texOnly_star = "^* "++texOnly_plus :: String+texOnly_plus = "^+ "++texOnly_bx :: String+texOnly_bx = " - "++texOnly_lRes :: String+texOnly_lRes = " / "++texOnly_rRes :: String+texOnly_rRes = " \\backslash "++texOnly_flip :: String+texOnly_flip = "\\smallsmile "
+ src/lib/DatabaseDesign/Ampersand/Output/PredLogic.hs view
@@ -0,0 +1,480 @@+{-# OPTIONS_GHC -Wall #-} --TODO verder opschonen van deze module
+module DatabaseDesign.Ampersand.Output.PredLogic
+           ( PredLogicShow(..), showLatex, mkVar
+           ) 
+   where
+
+   import Data.List
+   import DatabaseDesign.Ampersand.Basics
+   import DatabaseDesign.Ampersand.ADL1
+   import DatabaseDesign.Ampersand.Classes
+   import DatabaseDesign.Ampersand.Misc
+   import DatabaseDesign.Ampersand.Fspec.ShowADL
+   import Data.Char (toLower)
+   import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms (exprUni2list, exprIsc2list, exprCps2list, exprRad2list)
+   import DatabaseDesign.Ampersand.Output.PandocAux (latexEscShw,texOnly_Id)
+
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Output.PredLogic"
+
+ --  data PredVar = PV String     -- TODO Bedoeld om predicaten inzichtelijk te maken. Er bestaan namelijk nu verschillende manieren om hier mee om te gaan (zie ook Motivations. HJO. 
+   data PredLogic       
+    = Forall [Var] PredLogic            |
+      Exists [Var] PredLogic            |
+      Implies PredLogic PredLogic       |
+      Equiv PredLogic PredLogic         |
+      Conj [PredLogic]                  |
+      Disj [PredLogic]                  |
+      Not PredLogic                     |
+      Pred String String                |  -- Pred nm v, with v::type   is equiv. to Rel nm Nowhere [] (type,type) True (Sgn (showADL e) type type [] "" "" "" [Asy,Sym] Nowhere 0 False)
+      PlK0 PredLogic                    |
+      PlK1 PredLogic                    |
+      R PredLogic Declaration PredLogic |
+      Atom String                       |
+      Funs String [Declaration]         |
+      Dom Expression Var                |
+      Cod Expression Var                deriving Eq
+
+   data Notation = Flr | Frl | Rn | Wrap deriving Eq   -- yields notations y=r(x)  |  x=r(y)  |  x r y  | exists ... respectively.
+
+--   predKeyWords l = 
+--     case l of
+--        English  -> 
+
+   class PredLogicShow a where
+     showPredLogic :: Lang -> a -> String
+     showPredLogic l r =  
+       predLshow (natLangOps l) (toPredLogic r) -- predLshow produces raw LaTeX
+     toPredLogic :: a -> PredLogic
+
+   instance PredLogicShow Rule where
+     toPredLogic ru = assemble (rrexp ru)
+
+   instance PredLogicShow Expression where
+     toPredLogic = assemble
+
+
+-- showLatex ought to produce PandDoc mathematics instead of LaTeX source code.
+-- PanDoc, however, does not support mathematics sufficiently, as to date. For this reason we have showLatex.
+-- It circumvents the PanDoc structure and goes straight to LaTeX source code.
+-- TODO when PanDoc is up to the job.
+   showLatex :: PredLogic -> [(String,String,String)]
+   showLatex x
+    = chop (predLshow ("\\forall", "\\exists", implies, "\\Leftrightarrow", "\\vee", "\\ \\wedge\t", "^{\\asterisk}", "^{+}", "\\neg", rel, fun, mathVars, "", " ", apply, "\\in") x)
+      where rel r lhs rhs  -- TODO: the stuff below is very sloppy. This ought to be derived from the stucture, instead of by this naming convention.
+              = if isIdent r then lhs++"\\ =\\ "++rhs else
+                case name r of
+                 "lt"     -> lhs++"\\ <\\ "++rhs
+                 "gt"     -> lhs++"\\ >\\ "++rhs
+                 "le"     -> lhs++"\\ \\leq\\ "++rhs
+                 "leq"    -> lhs++"\\ \\leq\\ "++rhs
+                 "ge"     -> lhs++"\\ \\geq\\ "++rhs
+                 "geq"    -> lhs++"\\ \\geq\\ "++rhs
+                 _        -> lhs++"\\ \\id{"++latexEscShw (name r)++"}\\ "++rhs
+            fun r e = "\\id{"++latexEscShw (name r)++"}("++e++")"
+            implies antc cons = antc++" \\Rightarrow "++cons
+            apply :: Declaration -> String -> String -> String    --TODO language afhankelijk maken. 
+            apply decl d c =
+               case decl of
+                 Sgn{}     -> d++"\\ \\id{"++latexEscShw (name decl)++"}\\ "++c
+                 Isn{}     -> d++"\\ =\\ "++c
+                 Vs{}      -> "V"
+            mathVars :: String -> [Var] -> String
+            mathVars q vs
+             = if null vs then "" else
+               q++" "++intercalate "; " [intercalate ", " var++"\\coloncolon\\id{"++latexEscShw dType++"}" | (var,dType)<-vss]++":\n"
+               where
+                vss = [(map fst varCl,show(snd (head varCl))) |varCl<-eqCl snd vs]
+            chop :: String -> [(String,String,String)]
+            chop str = (map chops.lins) str
+             where
+               lins ""        = []
+               lins ('\n':cs) = "": lins cs
+               lins (c:cs)    = (c:r):rs where r:rs = case lins cs of  [] -> [""] ; e -> e
+               chops cs = let [a,b,c] = take 3 (tabs cs) in (a,b,c)
+               tabs "" = ["","","",""]
+               tabs ('\t':cs) = "": tabs cs
+               tabs (c:cs) = (c:r):rs where r:rs = tabs cs
+
+-- natLangOps exists for the purpose of translating a predicate logic expression to natural language.
+-- It yields a vector of mostly strings, which are used to assemble a natural language text in one of the natural languages supported by Ampersand.
+   natLangOps :: Identified a => Lang -> (String,
+                                          String,
+                                          String -> String -> String,
+                                          String,
+                                          String,
+                                          String,
+                                          String,
+                                          String,
+                                          String,
+                                          Declaration -> String -> String -> String,
+                                          a -> String -> String,
+                                          String -> [(String, A_Concept)] -> String,
+                                          String,
+                                          String,
+                                          Declaration -> String -> String -> String,
+                                          String)
+   natLangOps l
+            = case l of
+-- parameternamen:         (forallP,     existsP,        impliesP, equivP,             orP,  andP,  k0P, k1P, notP,  relP, funP, showVarsP, breakP, spaceP)
+                English -> ("For each",  "There exists", implies, "is equivalent to",  "or", "and", "*", "+", "not",  rel, fun,  langVars , "\n  ", " ", apply, "is element of")
+                Dutch   -> ("Voor elke", "Er is een",    implies, "is equivalent met", "of", "en",  "*", "+", "niet", rel, fun,  langVars , "\n  ", " ", apply, "is element van")
+               where
+                  rel r = apply r
+                  fun r x' = texOnly_Id(name r)++"("++x'++")"
+                  implies antc cons = case l of 
+                                        English  -> "If "++antc++", then "++cons
+                                        Dutch    -> "Als "++antc++", dan "++cons
+                  apply decl d c =
+                     case decl of
+                       Sgn{}     -> if null (prL++prM++prR) 
+                                      then "$"++d++"$ "++decnm decl++" $"++c++"$"
+                                      else prL++" $"++d++"$ "++prM++" $"++c++"$ "++prR
+                          where prL = decprL decl
+                                prM = decprM decl
+                                prR = decprR decl
+                       Isn{}     -> case l of 
+                                        English  -> "$"++d++"$ equals $"++c++"$"
+                                        Dutch    -> "$"++d++"$ is gelijk aan $"++c++"$"
+                       Vs{}      -> case l of 
+                                        English  -> show True
+                                        Dutch    -> "Waar"
+                  langVars :: String -> [(String, A_Concept)] -> String
+                  langVars q vs
+                      = case l of
+                         English | null vs     -> ""
+                                 | q=="Exists" -> 
+                                     intercalate " and " 
+                                     ["there exist"
+                                      ++(if length vs'==1 then "s a "++dType else ' ':plural English dType)
+                                      ++" called "
+                                      ++intercalate ", " ['$':v'++"$" | v'<-vs'] | (vs',dType)<-vss]
+                                 | otherwise   -> "If "++langVars "Exists" vs++", "
+                         Dutch   | null vs     -> ""
+                                 | q=="Er is"  -> 
+                                     intercalate " en "
+                                     ["er "
+                                       ++(if length vs'==1 then "is een "++dType else "zijn "++plural Dutch dType)
+                                       ++" genaamd "
+                                       ++intercalate ", " ['$':v'++"$" | v'<-vs'] | (vs',dType)<-vss]
+                                 | otherwise   -> "Als "++langVars "Er is" vs++", "
+                       where
+                        vss = [(map fst vs',show(snd (head vs'))) |vs'<-eqCl snd vs]
+
+-- predLshow exists for the purpose of translating a predicate logic expression to natural language.
+-- It uses a vector of operators (mostly strings) in order to produce text. This vector can be produced by, for example, natLangOps.
+-- example:  'predLshow (natLangOps l) e' translates expression 'e'
+-- into a string that contains a natural language representation of 'e'.
+   predLshow :: ( String                                    -- forallP
+                , String                                    -- existsP
+                , String -> String -> String                -- impliesP
+                , String                                    -- equivP
+                , String                                    -- orP
+                , String                                    -- andP
+                , String                                    -- kleene *
+                , String                                    -- kleene +
+                , String                                    -- notP
+                , Declaration -> String -> String -> String    -- relP
+                , Declaration -> String -> String              -- funP
+                , String -> [(String, A_Concept)] -> String -- showVarsP
+                , String                                    -- breakP
+                , String                                    -- spaceP
+                , Declaration -> String -> String -> String -- apply
+                , String                                    -- set element
+                ) -> PredLogic -> String
+   predLshow (forallP, existsP, impliesP, equivP, orP, andP, k0P, k1P, notP, relP, funP, showVarsP, breakP, spaceP, apply, el)
+    = charshow 0
+        where
+         wrap i j str = if i<=j then str else "("++str++")"
+         charshow :: Integer -> PredLogic -> String
+         charshow i predexpr
+          = case predexpr of
+                  Forall vars restr   -> wrap i 1 (showVarsP forallP vars ++ charshow 1 restr)
+                  Exists vars restr   -> wrap i 1 (showVarsP existsP vars  ++ charshow 1 restr)
+                  Implies antc conseq -> wrap i 2 (breakP++impliesP (charshow 2 antc) (charshow 2 conseq))
+                  Equiv lhs rhs       -> wrap i 2 (breakP++charshow 2 lhs++spaceP++equivP++spaceP++ charshow 2 rhs)
+                  Disj rs             -> if null rs 
+                                         then "" 
+                                         else wrap i 3 (intercalate (spaceP++orP ++spaceP) (map (charshow 3) rs))
+                  Conj rs             -> if null rs 
+                                         then "" 
+                                         else wrap i 4 (intercalate (spaceP++andP++spaceP) (map (charshow 4) rs))
+                  Funs x ls           -> case ls of
+                                            []    -> x
+                                            r:ms  -> if isIdent r then charshow i (Funs x ms) else charshow i (Funs (funP r x) ms)
+                  Dom expr (x,_)      -> x++el++funP (makeRel "dom") (showADL expr)
+                  Cod expr (x,_)      -> x++el++funP (makeRel "cod") (showADL expr)
+                  R pexpr dec pexpr'  -> case (pexpr,pexpr') of
+                                            (Funs l [] , Funs r [])  -> wrap i 5 (apply dec l r)
+{-
+                                            (Funs l [f], Funs r [])  -> wrap i 5 (if isIdent rel
+                                                                                  then apply (makeDeclaration f) l r
+                                                                                  else apply (makeDeclaration rel) (funP f l) r)
+                                            (Funs l [] , Funs r [f]) -> wrap i 5 (if isIdent rel
+                                                                                  then apply (makeDeclaration f) l r
+                                                                                  else apply (makeDeclaration rel) l (funP f r))
+-}
+                                            (lhs,rhs)                -> wrap i 5 (relP dec (charshow 5 lhs) (charshow 5 rhs))
+                  Atom atom           -> "'"++atom++"'"
+                  PlK0 rs             -> wrap i 6 (charshow 6 rs++k0P)
+                  PlK1 rs             -> wrap i 7 (charshow 7 rs++k1P)
+                  Not rs              -> wrap i 8 (spaceP++notP++charshow 8 rs)
+                  Pred nm v'          -> nm++"{"++v'++"}"
+         makeRel :: String -> Declaration -- This function exists solely for the purpose of dom and cod
+         makeRel str
+             =    Sgn { decnm   = str
+                      , decsgn  = fatal 217 "Do not refer to decsgn of this dummy relation"
+                      , decprps = [Uni,Tot]
+                      , decprps_calc = Nothing
+                      , decprL  = ""
+                      , decprM  = ""
+                      , decprR  = ""
+                      , decMean = fatal 223 "Do not refer to decMean of this dummy relation"
+                      , decConceptDef = Nothing
+                      , decfpos = OriginUnknown
+                      , decissX = fatal 226 "Do not refer to decissX of this dummy relation"
+                      , decusrX = False
+                      , decISA  = False
+                      , decpat  = fatal 228 "Do not refer to decpat of this dummy relation"
+                      , decplug = fatal 229 "Do not refer to decplug of this dummy relation"
+                      }
+
+--objOrShow :: Lang -> PredLogic -> String
+--objOrShow l = predLshow ("For all", "Exists", implies, " = ", " = ", "<>", "OR", "AND", "*", "+", "NOT", rel, fun, langVars l, "\n", " ")
+--               where rel r lhs rhs = applyM (makeDeclaration r) lhs rhs
+--                     fun r x = x++"."++name r
+--                     implies antc cons = "IF "++antc++" THEN "++cons
+
+-- The function 'assemble' translates a rule to predicate logic.
+-- In order to remain independent of any representation, it transforms the Haskell data structure Rule
+-- into the data structure PredLogic, rather than manipulate with texts.
+   type Var = (String,A_Concept)
+   assemble :: Expression -> PredLogic
+   assemble expr
+    = case (source expr, target expr) of
+           (ONE, ONE) -> rc
+           (_  , ONE) -> Forall [s] rc
+           (ONE, _)   -> Forall [t] rc
+           (_  , _)   -> Forall [s,t] rc
+     where
+      [s,t] = mkVar [] [source expr, target expr]
+      rc = f [s,t] expr (s,t)
+      f :: [Var] -> Expression -> (Var,Var) -> PredLogic
+      f exclVars (EEqu (l,r)) (a,b)  = Equiv (f exclVars l (a,b)) (f exclVars r (a,b))
+      f exclVars (EImp (l,r)) (a,b)  = Implies (f exclVars l (a,b)) (f exclVars r (a,b))
+      f exclVars e@EIsc{}     (a,b)  = Conj [f exclVars e' (a,b) | e'<-exprIsc2list e]
+      f exclVars e@EUni{}     (a,b)  = Disj [f exclVars e' (a,b) | e'<-exprUni2list e]
+      f exclVars (EDif (l,r)) (a,b)  = Conj [f exclVars l (a,b), Not (f exclVars r (a,b))]
+      f exclVars (ELrs (l,r)) (a,b)  = Forall [c] (Implies (f eVars r (b,c)) (f eVars l (a,c)))
+                                       where [c]   = mkVar exclVars [target l]
+                                             eVars = exclVars++[c]
+      f exclVars (ERrs (l,r)) (a,b)  = Forall [c] (Implies (f eVars l (c,a)) (f eVars r (c,b)))
+                                       where [c]   = mkVar exclVars [source l]
+                                             eVars = exclVars++[c]
+      f exclVars e@ECps{}     (a,b)  = fECps exclVars e (a,b)  -- special treatment, see below
+      f exclVars e@ERad{}     (a,b)  = fERad exclVars e (a,b)  -- special treatment, see below
+      f _        (EPrd (l,r)) (a,b)  = Conj [Dom l a, Cod r b]
+      f exclVars (EKl0 e)     (a,b)  = PlK0 (f exclVars e (a,b))
+      f exclVars (EKl1 e)     (a,b)  = PlK1 (f exclVars e (a,b))
+      f exclVars (ECpl e)     (a,b)  = Not (f exclVars e (a,b))
+      f exclVars (EBrk e)     (a,b)  = f exclVars e (a,b)
+      f _ e@(EDcD dcl) ((a,sv),(b,tv)) = res
+       where
+        res = case denote e of
+               Flr  -> R (Funs a [dcl]) (Isn tv) (Funs b [])
+               Frl  -> R (Funs a []) (Isn sv) (Funs b [dcl])
+               Rn   -> R (Funs a []) (dcl) (Funs b [])
+               Wrap -> fatal 246 "function res not defined when denote e == Wrap. "
+      f _ e@(EFlp (EDcD dcl)) ((a,sv),(b,tv)) = res
+       where
+        res = case denote e of
+               Flr  -> R (Funs a [dcl]) (Isn tv) (Funs b [])
+               Frl  -> R (Funs a []) (Isn sv) (Funs b [dcl])
+               Rn   -> R (Funs b []) (dcl) (Funs a [])
+               Wrap -> fatal 253 "function res not defined when denote e == Wrap. "
+      f exclVars (EFlp e)       (a,b) = f exclVars e (b,a)
+      f _ (EMp1 atom _) _             = Atom atom
+      f _ (EDcI _) ((a,_),(b,tv))     = R (Funs a []) (Isn tv) (Funs b [])
+      f _ (EDcV _) _                  = Atom "True"
+
+-- fECps treats the case of a composition.  It works as follows:
+--       An expression, e.g. r;s;t , is translated to Exists (zip ivs ics) (Conj (frels s t)),
+--       in which ivs is a list of variables that are used inside the resulting expression,
+--       ics contains their types, and frels s t the subexpressions that
+--       are used in the resulting conjuct (at the right of the quantifier).
+      fECps :: [Var] -> Expression -> (Var,Var) -> PredLogic
+      fECps exclVars    e             (a,b)
+                               --   f :: [Var] -> Expression -> (Var,Var) -> PredLogic
+        | and [isCpl e' | e'<-es] = f exclVars (deMorganECps e) (a,b)
+        | otherwise               = Exists ivs (Conj (frels a b))
+        where
+         es :: [Expression]
+         es   = [ x | x<-exprCps2list e, not (isEpsilon x) ]
+        -- Step 1: split in fragments at those points where an exists-quantifier is needed.
+        --         Each fragment represents a subexpression with variables
+        --         at the outside only. Fragments will be reconstructed in a conjunct.
+         res :: [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
+         res = pars3 (exclVars++ivs) (split es)  -- yields triples (r,s,t): the fragment, its source and target.
+        -- Step 2: assemble the intermediate variables from at the right spot in each fragment.
+         frels :: Var -> Var -> [PredLogic]
+         frels src trg = [r v w | ((r,_,_),v,w)<-zip3 res' (src: ivs) (ivs++[trg]) ]
+        -- Step 3: compute the intermediate variables and their types
+         res' :: [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
+         res' = [triple | triple<-res, not (atomic triple)]
+         ivs ::  [Var]
+         ivs  = mkvar exclVars ics
+         ics ::  [ Either PredLogic A_Concept ] -- each element is either an atom or a concept
+         ics  = concat
+                [ case (v',w) of
+                    (Left _,    Left _   ) -> []
+                    (Left atom, Right  _ ) -> [ Left atom ]
+                    (Right  _ , Left atom) -> [ Left atom ]
+                    (Right trg, Right src) -> [ Right trg ] -- SJ 20131117, was: (if trg==src then [ Right trg ] else [ Right (trg `meet` src) ])
+                                                            -- This code assumes no ISA's in the A-structure. This works due to the introduction of EEps expressions.
+                | (v',w)<-zip [ case l ("",src) ("",trg) of
+                                 atom@Atom{} -> Left atom
+                                 _           -> Right trg
+                              | (l,src,trg)<-init res]
+                              [ case r ("",src) ("",trg) of
+                                 atom@Atom{} -> Left atom
+                                 _           -> Right src
+                              | (r,src,trg)<-tail res]
+                ]
+      atomic :: (Var -> Var -> PredLogic, A_Concept, A_Concept) -> Bool
+      atomic (r,a,b) = case r ("",a) ("",b) of
+                        Atom{} -> True
+                        _      -> False
+      mkvar :: [Var] -> [ Either PredLogic A_Concept ] -> [Var]
+      mkvar exclVars (Right z: ics) = let vz = head (mkVar exclVars [z]) in vz: mkvar (exclVars++[vz]) ics
+      mkvar exclVars (Left  _: ics) = mkvar exclVars ics
+      mkvar _ [] = []
+
+      fERad :: [Var] -> Expression -> (Var,Var) -> PredLogic
+      fERad exclVars e (a,b) 
+        | and[isCpl e' |e'<-es] = f exclVars (deMorganERad e) (a,b)                      -- e.g.  -r!-s!-t
+        | isCpl (head es)       = f exclVars (foldr1 (.:.) antr .\. foldr1 (.!.) conr) (a,b)  -- e.g.  -r!-s! t  antr cannot be empty, because isCpl (head es) is True; conr cannot be empty, because es has an element that is not isCpl.
+        | isCpl (last es)       = f exclVars (foldr1 (.!.) conl ./. foldr1 (.:.) antl) (a,b)  -- e.g.   r!-s!-t  antl cannot be empty, because isCpl (head es) is True; conl cannot be empty, because es has an element that is not isCpl.
+        | otherwise             = Forall ivs (Disj (frels a b))                               -- e.g.   r!-s! t  the condition or [isCpl e' |e'<-es] is true.
+{- was:
+        | otherwise             = Forall ivs (Disj alls)
+                                  where alls = [f (exclVars++ivs) e' (sv,tv) | (e',(sv,tv))<-zip es (zip (a:ivs) (ivs++[b]))]
+-}
+        where
+         es   = [ x | x<-exprRad2list e, not (isEpsilon x) ] -- The definition of exprRad2list guarantees that length es>=2
+         res  = pars3 (exclVars++ivs) (split es)  -- yields triples (r,s,t): the fragment, its source and target.
+         conr = dropWhile isCpl es -- There is at least one positive term, because conr is used in the second alternative (and the first alternative deals with absence of positive terms).
+                                   -- So conr is not empty.
+         antr = let x = (map notCpl.map flp.reverse.takeWhile isCpl) es in
+                if null x then fatal 367 ("Entering in an empty foldr1") else x
+         conl = let x = (reverse.dropWhile isCpl.reverse) es in
+                if null x then fatal 369 ("Entering in an empty foldr1") else x
+         antl = let x = (map notCpl.map flp.takeWhile isCpl.reverse) es in
+                if null x then fatal 371 ("Entering in an empty foldr1") else x
+        -- Step 2: assemble the intermediate variables from at the right spot in each fragment.
+         frels :: Var -> Var -> [PredLogic]
+         frels src trg = [r v w | ((r,_,_),v,w)<-zip3 res' (src: ivs) (ivs++[trg]) ]
+        -- Step 3: compute the intermediate variables and their types
+         res' :: [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
+         res' = [triple | triple<-res, not (atomic triple)]
+         ivs ::  [Var]
+         ivs  = mkvar exclVars ics
+         ics ::  [ Either PredLogic A_Concept ] -- each element is either an atom or a concept
+         ics  = concat
+                [ case (v',w) of
+                    (Left _,    Left _   ) -> []
+                    (Left atom, Right  _ ) -> [ Left atom ]
+                    (Right  _ , Left atom) -> [ Left atom ]
+                    (Right trg, Right src) -> [ Right trg ] -- SJ 20131117, was: (if trg==src then [ Right trg ] else [ Right (trg `meet` src) ])
+                                                            -- This code assumes no ISA's in the A-structure. This works due to the introduction of EEps expressions.
+                | (v',w)<-zip [ case l ("",src) ("",trg) of
+                                 atom@Atom{} -> Left atom
+                                 _           -> Right trg
+                              | (l,src,trg)<-init res]
+                              [ case r ("",src) ("",trg) of
+                                 atom@Atom{} -> Left atom
+                                 _           -> Right src
+                              | (r,src,trg)<-tail res]
+                ]
+
+      relFun :: [Var] -> [Expression] -> Expression -> [Expression] -> Var->Var->PredLogic
+      relFun exclVars lhs e rhs
+        = case e of
+            EDcD dcl        -> \sv tv->R (Funs (fst sv) [r | t'<-        lhs, r<-declsUsedIn t']) dcl (Funs (fst tv) [r | t'<-reverse rhs, r<-declsUsedIn t'])
+            EFlp (EDcD dcl) -> \sv tv->R (Funs (fst tv) [r | t'<-reverse rhs, r<-declsUsedIn t']) dcl (Funs (fst sv) [r | t'<-        lhs, r<-declsUsedIn t'])
+            EMp1 atom _     -> \_ _->Atom atom
+            EFlp EMp1{}     -> relFun exclVars lhs e rhs
+            _               -> \sv tv->f (exclVars++[sv,tv]) e (sv,tv)       
+
+      pars3 :: [Var] -> [[Expression]] -> [(Var -> Var -> PredLogic, A_Concept, A_Concept)] 
+      pars3 exclVars (lhs: [e]: rhs: ts)
+       | denotes lhs==Flr && denote e==Rn && denotes rhs==Frl
+          = ( relFun exclVars lhs e rhs, source (head lhs), target (last rhs)): pars3 exclVars ts
+       | otherwise = pars2 exclVars (lhs:[e]:rhs:ts)
+      pars3 exclVars ts = pars2 exclVars ts -- for lists shorter than 3
+
+      pars2 :: [Var] -> [[Expression]]-> [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
+      pars2 exclVars (lhs: [e]: ts)
+       | denotes lhs==Flr && denote e==Rn
+                   = (relFun exclVars lhs e [], source (head lhs), target e): pars3 exclVars ts
+       | denotes lhs==Flr && denote e==Frl
+                   = (relFun exclVars lhs (EDcI (source e)) [e], source (head lhs), target e): pars3 exclVars ts
+       | otherwise = pars1 exclVars (lhs:[e]:ts)
+      pars2 exclVars ([e]: rhs: ts)
+       | denotes rhs==Frl && denote e==Rn
+                   = (relFun exclVars [] e rhs, source e, target (last rhs)): pars3 exclVars ts
+       | denote e==Flr && denotes rhs==Frl
+                   = (relFun exclVars [e] (EDcI (source e)) rhs, source e, target (last rhs)): pars3 exclVars ts
+       | otherwise = pars1 exclVars ([e]:rhs:ts)
+      pars2 exclVars (lhs: rhs: ts)
+       | denotes lhs==Flr && denotes rhs==Frl
+                   = (relFun exclVars lhs (EDcI (source (head rhs))) rhs, source (head lhs), target (last rhs)): pars3 exclVars ts
+       | otherwise = pars1 exclVars (lhs:rhs:ts)
+      pars2 exclVars ts = pars1 exclVars ts -- for lists shorter than 2
+
+      pars1 :: [Var] -> [[Expression]] -> [(Var -> Var -> PredLogic, A_Concept, A_Concept)]
+      pars1 exclVars expressions
+        = case expressions of
+            []        -> []
+            (lhs: ts) -> (pars0 exclVars lhs, source (head lhs), target (last lhs)): pars3 exclVars ts
+
+      pars0 :: [Var] -> [Expression] -> Var -> Var -> PredLogic
+      pars0 exclVars lhs
+       | denotes lhs==Flr = relFun exclVars lhs (EDcI (source (last lhs))) []
+       | denotes lhs==Frl = relFun exclVars []  (EDcI (target (last lhs))) lhs
+       | otherwise        = relFun exclVars [] (let [r]=lhs in r) []
+
+      denote :: Expression -> Notation
+      denote e = case e of
+         (EDcD d)
+           | null([Uni,Inj,Tot,Sur] >- multiplicities d)  -> Rn
+           | isUni d && isTot d                           -> Flr
+           | isInj d && isSur d                           -> Frl
+           | otherwise                                    -> Rn 
+         _                                                -> Rn
+      denotes :: [Expression] -> Notation
+      denotes = denote . head
+
+      split :: [Expression] -> [[Expression]]
+      split []  = []
+      split [e] = [[e]]
+      split (e:e':es)
+       = --if denote e `eq` Wrap      then (e:spl):spls else
+         if denote e `eq` denote e' then (e:spl):spls else
+                                         [e]:spl:spls
+         where 
+           spl:spls = split (e':es)
+           Flr `eq` Flr = True
+           Frl `eq` Frl = True
+           _ `eq` _     = False
+
+        
+-- mkVar is bedoeld om nieuwe variabelen te genereren, gegeven een set (ex) van reeds vergeven variabelen.
+-- mkVar garandeert dat het resultaat niet in ex voorkomt, dus postconditie:   not (mkVar ex cs `elem` ex)
+-- Dat gebeurt door het toevoegen van apostrofes.
+   mkVar :: [Var] -> [A_Concept] -> [Var]  
+   mkVar ex cs = mknew (map fst ex) [([(toLower.head.(++"x").name) c],c) |c<-cs]
+    where
+     mknew _ [] = []
+     mknew ex' ((x,c):xs) = if x `elem` ex'
+                            then mknew ex' ((x++"'",c):xs)
+                            else (x,c): mknew (ex'++[x]) xs
+ src/lib/DatabaseDesign/Ampersand/Output/Statistics.hs view
@@ -0,0 +1,57 @@+{-# OPTIONS_GHC -Wall #-}
+module DatabaseDesign.Ampersand.Output.Statistics (Statistics(..)) where
+
+   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+   import DatabaseDesign.Ampersand.Classes
+   import DatabaseDesign.Ampersand.Fspec.Fspec
+   import DatabaseDesign.Ampersand.Fspec.FPA
+   import DatabaseDesign.Ampersand.Fspec.Plug ()
+   import DatabaseDesign.Ampersand.Basics (fatalMsg)
+
+   fatal :: Int -> String -> a
+   fatal = fatalMsg "Output.Statistics"
+
+ -- TODO Deze module moet nog verder worden ingekleurd...
+ 
+   class Statistics a where
+    nInterfaces :: a -> Int      -- ^ The number of interfaces in a
+    nPatterns :: a -> Int      -- ^ The number of patterns in a
+    nFpoints :: a -> Int      -- ^ The number of function points in a
+    
+    
+   instance Statistics a => Statistics [a] where
+    nInterfaces xs = sum (map nInterfaces xs)
+    nPatterns   xs = sum (map nPatterns xs)
+    nFpoints    xs = sum (map nFpoints xs)
+
+
+   instance Statistics Fspc where
+    nInterfaces fSpec = length (fActivities fSpec) --TODO -> check correctness
+    nPatterns   fSpec = nPatterns (patterns fSpec)
+    nFpoints    fSpec = sum [nFpoints ifc | ifc <- (interfaceS fSpec++interfaceG fSpec)] 
+                --       + sum [fPoints (fpa plug) | InternalPlug plug <- plugInfos fSpec]
+-- TODO Deze module moet nog verder worden ingekleurd...
+   
+   instance Statistics Pattern where
+    nInterfaces _ = 0 --TODO -> check correctness
+    nPatterns   _ = 1
+    nFpoints   _  = fatal 43 "function points are not defined for patterns at all."
+
+--   instance Statistics Activity where
+--    nInterfaces _ = 1
+--    nPatterns   _ = 0
+--    nFpoints act  = fPoints (actFPA act) --TODO -> implement correct FPA qualification
+
+-- \***********************************************************************
+-- \*** Properties with respect to: Dataset                       ***
+-- \*** TODO: both datasets and interfaces are represented as ObjectDef. This does actually make a difference for the function point count, so we have work....
+   instance Statistics Interface where
+    nInterfaces _ = 1
+    nPatterns   _ = 0
+    nFpoints ifc  = fPoints ifc
+
+--   instance Statistics ObjectDef where
+--    nInterfaces (Obj{objmsub=Nothing}) = 2 -- this is an association, i.e. a binary relation --TODO -> check correctness
+--    nInterfaces _ = 4 -- this is an entity with one or more attributes. --TODO -> check correctness
+--    nPatterns   _ = 0
+--    nFpoints    _ = fatal 60 "function points are not defined for ObjectDefs at all."
+ src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs view
@@ -0,0 +1,160 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterConceptualAnalysis
+where
+import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters
+import DatabaseDesign.Ampersand.ADL1 (Prop(..)) 
+import DatabaseDesign.Ampersand.Output.PredLogic        (PredLogicShow(..), showLatex)
+import DatabaseDesign.Ampersand.Classes
+import DatabaseDesign.Ampersand.Output.PandocAux
+import Data.List (intercalate)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.ChapterConceptualAnalysis"
+
+chpConceptualAnalysis :: Int -> Fspc -> Options -> (Blocks,[Picture])
+chpConceptualAnalysis lev fSpec flags = (chptHeader flags ConceptualAnalysis <> caIntro <> caBlocks, pictures)
+  where
+  caIntro :: Blocks
+  caIntro
+   = fromList $ (case language flags of
+        Dutch   -> [Para
+                    [ Str "Dit hoofdstuk beschrijft een formele taal, waarin functionele eisen ten behoeve van "
+                    , Quoted  SingleQuote [Str (name fSpec)]
+                    , Str " kunnen worden besproken en uitgedrukt. "
+                    , Str "De formalisering dient om een bouwbare specificatie te verkrijgen. "
+                    , Str "Een derde met voldoende deskundigheid kan op basis van dit hoofdstuk toetsen of de gemaakte afspraken "
+                    , Str "overeenkomen met de formele regels en definities. "
+                   ]]
+        English -> [Para
+--                    [ Str "This chapter provides an analysis of the principles described in chapter "
+--                    
+--                    , Str ". Each section in that chapter is analysed in terms of relations "
+--                    , Str "and each principle is then translated in a rule. "
+                    [ Str "This chapter defines the formal language, in which functional requirements of "
+                    , Quoted  SingleQuote [Str (name fSpec)]
+                    , Str " can be analysed and expressed."
+                    , Str "The purpose of this formalisation is to obtain a buildable specification. "
+                    , Str "This chapter allows an independent professional with sufficient background to check whether the agreements made "
+                    , Str "correspond to the formal rules and definitions. "
+                    ]])
+     ++ purposes2Blocks flags (purposesDefinedIn fSpec (language flags) fSpec) -- This explains the purpose of this context.
+     
+  caBlocks = fromList $ concat(map caSection (patterns fSpec))
+  pictures =        map pict      (patterns fSpec)
+  -----------------------------------------------------
+  -- the Picture that represents this pattern's conceptual graph
+  pict :: Pattern -> Picture
+  pict pat = (makePicture flags fSpec Plain_CG pat)
+                {caption = case language flags of
+                            Dutch   ->"Conceptdiagram van "++name pat
+                            English ->"Concept diagram of "++name pat}
+  caSection :: Pattern -> [Block]
+  caSection pat
+   =    -- new section to explain this pattern  
+        toList ( labeledThing flags (lev+1) (xLabel ConceptualAnalysis++"_"++name pat) (name pat))
+        -- The section starts with the reason why this pattern exists 
+     ++ purposes2Blocks flags (purposesDefinedIn fSpec (language flags) pat)
+        -- followed by a conceptual model for this pattern
+     ++ ( case (genGraphics flags, language flags) of
+               (True,Dutch  ) -> -- announce the conceptual diagram
+                                 [Para [Str "Figuur ", xrefReference (pict pat), Str " geeft een conceptueel diagram van dit pattern."]
+                                 -- draw the conceptual diagram
+                                 ,Plain (xrefFigure1 (pict pat))]          
+               (True,English) -> [Para [Str "Figure ", xrefReference (pict pat), Str " shows a conceptual diagram of this pattern."]
+                                 ,Plain (xrefFigure1 (pict pat))]
+               _              -> [])
+        -- now provide the text of this pattern.
+     ++ (case language flags of
+           Dutch   -> [Para [Str "De definities van concepten zijn te vinden in de index."]
+                      ]++
+                      toList (labeledThing flags (lev+2) (xLabel ConceptualAnalysis++"_relationsOf_"++name pat) "Gedeclareerde relaties")
+                      ++
+                      [Para [Str "Deze paragraaf geeft een opsomming van de gedeclareerde relaties met eigenschappen en een betekenis."]]
+           English -> [Para [Str "The definitions of concepts can be found in the glossary."]
+                      ]++
+                      toList (labeledThing flags (lev+2) (xLabel ConceptualAnalysis++"_relationsOf_"++name pat) "Declared relations")
+                      ++
+                      [Para [Str "This section itemizes the declared relations with properties and a meaning."]])
+     ++ [DefinitionList blocks | let blocks = map caRelation (declarations pat), not(null blocks)]
+     ++ (case language flags of
+           Dutch   -> toList (labeledThing flags (lev+2) (xLabel ConceptualAnalysis++"_rulesOf_"++name pat) "Formele regels")
+                      ++
+                      [Plain [Str "Deze paragraaf geeft een opsomming van de formele regels met een verwijzing naar de gemeenschappelijke taal van de belanghebbenden ten behoeve van de traceerbaarheid."]]
+           English -> toList (labeledThing flags (lev+2) (xLabel ConceptualAnalysis++"_rulesOf_"++name pat) "Formal rules")
+                      ++
+                      [Plain [Str "This section itemizes the formal rules with a reference to the shared language of stakeholders for the sake of traceability."]])
+     ++ [DefinitionList blocks | let blocks = map caRule (invariants pat `isc` udefrules pat), not(null blocks)]
+
+  caRelation :: Declaration -> ([Inline], [[Block]])
+  caRelation d 
+        = let purp = purposes2Blocks flags [p | p<-purposesDefinedIn fSpec (language flags) d]
+          in ([]
+             ,[   -- First the reason why the relation exists, if any, with its properties as fundamental parts of its being..
+                ( if null purp
+                  then [ Plain$[ Str ("De volgende "++nladjs d++" relatie is gedeclareerd ")      | language flags==Dutch]
+                            ++ [ Str ("The following "++ukadjs d++" relation has been declared ") | language flags==English] ]
+                  else purp ) -- If there is a purpose, its text should introduce the declaration and the generator remains silent.
+                  -- Then the declaration of the relation with its properties and its intended meaning 
+               ++ pandocEqnArray 
+                     [ ( texOnly_Id(name d)
+                       , ":"
+                       , texOnly_Id(name (source d))++(if isFunction d then texOnly_fun else texOnly_rel)++texOnly_Id(name(target d))++symDefLabel d
+                       )  ]
+               ++ [Plain$[Str "(Geen betekenis gespecificeerd)"| language flags==Dutch]
+                      ++ [Str "(No meaning has been specified)"  | language flags==English]
+                  | null (meaning2Blocks (language flags) d)]
+               ++ meaning2Blocks (language flags) d
+              ])
+  ukadjs d = intercalate ", " (map ukadj (multiplicities d))
+  ukadj Uni = "univalent"
+  ukadj Inj = "injective"
+  ukadj Sur = "surjective"
+  ukadj Tot = "total"
+  ukadj Sym = "symmetric"
+  ukadj Asy = "antisymmetric"
+  ukadj Trn = "transitive"
+  ukadj Rfx = "reflexive"
+  ukadj Irf = "irreflexive"
+  nladjs d = intercalate ", " (map nladj (multiplicities d))
+  nladj Uni = "univalente"
+  nladj Inj = "injectieve"
+  nladj Sur = "surjectieve"
+  nladj Tot = "totale"
+  nladj Sym = "symmetrische"
+  nladj Asy = "antisymmetrische"
+  nladj Trn = "transitieve"
+  nladj Rfx = "reflexieve"
+  nladj Irf = "irreflexieve"
+  caRule :: Rule -> ([Inline], [[Block]])
+  caRule r 
+        = let purp = purposes2Blocks flags (purposesDefinedIn fSpec (language flags) r)
+          in ( []
+             , [  -- First the reason why the rule exists, if any..
+                  purp  
+                  -- Then the rule as a requirement
+               ++ [Plain$[if null purp then Str "De volgende afspraak is gesteld in paragraaf " 
+                                       else Str "Daarom is als afspraak gesteld in paragraaf " | language flags==Dutch]
+                      ++ [if null purp then Str "The following requirement has been defined in section " 
+                                       else Str "Therefore the following requirement has been defined in section " | language flags==English]
+                      ++ [RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "~"
+                         ,RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ symReqRef r
+                         ,Str " p."
+                         ,RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "~"
+                         ,RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ symReqPageRef r
+                         ,Str ": "]]
+               ++ meaning2Blocks (language flags) r
+                  -- then the formal rule
+               ++ [Plain$[Str "Dit is geformaliseerd - gebruikmakend van relaties " | language flags==Dutch]
+                      ++ [Str "This is formalized - using relations "     | language flags==English]
+                      ++ intercalate [Str ", "] [[RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ symDefRef d] | d@Sgn{}<-declsUsedIn r]
+                      ++ [Str " - als " | language flags==Dutch]
+                      ++ [Str " - as "     | language flags==English]]
+               ++ (if showPredExpr flags
+                   then pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
+                   else pandocEquation (showMath r++symDefLabel r)
+                  )
+               ])
+
+
+
+ src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs view
@@ -0,0 +1,809 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDataAnalysis (chpDataAnalysis)
+where 
+import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
+import DatabaseDesign.Ampersand.ADL1
+import DatabaseDesign.Ampersand.Classes
+import DatabaseDesign.Ampersand.Fspec.Fspec
+import DatabaseDesign.Ampersand.Output.PredLogic        (PredLogicShow(..), showLatex)
+import DatabaseDesign.Ampersand.Output.PandocAux
+import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram --(Class(..),CdAttribute(..))
+import Data.List (sortBy)
+import Data.Function (on)
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.ChapterDataAnalysis"
+
+------------------------------------------------------------
+--DESCR -> the data analysis contains a section for each class diagram in the fspec
+--         the class diagram and multiplicity rules are printed
+chpDataAnalysis :: Fspc -> Options -> (Blocks,[Picture])
+chpDataAnalysis fSpec flags = (theBlocks, thePictures)
+ where 
+ 
+  theBlocks 
+    =  chptHeader flags DataAnalysis  -- The header
+    <> (case language flags of 
+             Dutch   -> para ( text "Dit hoofdstuk bevat het resultaat van de gegevensanalyse. "
+                            <> text "De opbouw is als volgt:"
+                             )
+                     <> para ( if summaryOnly
+                               then text "We beginnen met "
+                               else text "We beginnen met het classificatiemodel, gevolgd door "
+                            <> text "een overzicht van alle relaties, die samen de basis vormen van de rest van deze analyse. "
+                            <> text "tenslotte volgen achtereenvolgend het logische- en technische gegevensmodel."
+                             )   
+             English -> para ( text "This chapter contains the result of the data analisys. "
+                            <> text "It is structured as follows:"
+                             )
+                     <> para ( if summaryOnly
+                               then text "We start with "
+                               else text "We start with the classification model, followed by "
+                            <> text "a list of all relations, that are the foundation of the rest of the analisys. "
+                            <> text "Finally, the logical and technical data model are discussed."
+                             )   
+       )
+    <> if summaryOnly then mempty else classificationBlocks
+    <> daBasicBlocks
+    <> logicalDataModelBlocks
+    <> technicalDataModelBlocks
+  thePictures
+    =  [classificationPicture | not summaryOnly]
+    ++ logicalDataModelPictures ++ technicalDataModelPictures
+
+  daBasicBlocks                                          = daBasicsSection           sectionLevel fSpec flags
+  (classificationBlocks    , classificationPicture     ) = classificationSection     sectionLevel fSpec flags
+  (logicalDataModelBlocks  , logicalDataModelPictures  ) = logicalDataModelSection   sectionLevel fSpec flags
+  (technicalDataModelBlocks, technicalDataModelPictures) = technicalDataModelSection sectionLevel fSpec flags
+  sectionLevel = 2
+
+  -- | In some cases, only a summary of the data analysis is required as output.
+  summaryOnly :: Bool
+  summaryOnly = theme flags `elem` [StudentTheme]
+  
+
+classificationSection :: Int -> Fspc -> Options -> (Blocks,Picture)
+classificationSection lev fSpec flags = (theBlocks,pict)
+ where 
+  theBlocks =
+       header lev (case language flags of
+                    Dutch   -> text "Classificaties"
+                    English -> text "Classifications"
+                  )
+    <> content
+  content = 
+    if null (classes classificationModel)
+    then para $ text "Er zijn geen classificaties gedefinieerd."
+    else para (case language flags of 
+              Dutch   -> text "Een aantal concepten zit in een classificatiestructuur. "
+                       <> (if canXRefer flags 
+                           then text "Deze is in figuur " <> xRefReference flags pict <> text "weergegeven."
+                           else text "Deze is in onderstaand figuur weergegeven."
+                          )
+              English -> text "A number of concepts is organized in a classification structure. "
+                       <> (if canXRefer flags 
+                           then text "This is shown in figure " <> xRefReference flags pict <> text "."
+                           else text "This is shown in the figure below."
+                          )
+            )
+         <> para (showImage flags pict)
+     
+   where
+  classificationModel :: ClassDiag
+  classificationModel = clAnalysis fSpec flags
+
+  pict :: Picture
+  pict = (makePicture flags fSpec Gen_CG classificationModel)
+          {caption = case language flags of
+                       Dutch   ->"Classificatie van "++name fSpec
+                       English ->"Classification of "++name fSpec}
+
+
+logicalDataModelSection :: Int -> Fspc -> Options -> (Blocks,[Picture])
+logicalDataModelSection lev fSpec flags = (theBlocks, [pict])
+ where
+  theBlocks =
+       header lev (case language flags of
+                    Dutch   -> text "Logisch gegevensmodel"
+                    English -> text "Logical datamodel"
+                )
+    <> para (case language flags of
+               Dutch   -> (text "De afspraken zijn vertaald naar een gegevensmodel. "
+                         <> ( if canXRefer flags
+                              then text "Dit gegevensmodel is in figuur " <> xRefReference flags pict <> text " weergegeven."
+                              else text "Dit gegevensmodel is in onderstaand figuur weergegeven. "
+                          ) )
+               English -> (text "The functional requirements have been translated into a data model. "
+                         <> ( if canXRefer flags
+                              then text "This model is shown by figure " <> xRefReference flags pict <> text "."
+                              else text "This model is shown by the figure below. "
+                          ) )
+            )
+     <> para (showImage flags pict)
+     <> let nrOfClasses = length (classes oocd)
+        in case language flags of
+             Dutch   -> para (case nrOfClasses of
+                                0 -> text "Er zijn geen gegevensverzamelingen."
+                                1 -> text "Er is één gegevensverzameling, die in de volgende paragraaf in detail is beschreven:"
+                                _ -> text ("Er zijn "++count flags nrOfClasses "gegevensverzameling"++". ") 
+                                  <> text "De details van elk van deze gegevensverzameling worden, op alfabetische volgorde, in de nu volgende paragrafen beschreven:"
+                             )
+             English -> para (case nrOfClasses of
+                                0 -> text "There are no entity types."
+                                1 -> text "There is only one entity type:"
+                                _ -> text ("There are "++count flags nrOfClasses "entity type" ++".")
+                                  <> text "The details of each entity type are described (in alfabetical order) in the following paragraphs:"
+                             )
+     <> mconcat (map detailsOfClass (sortBy (compare `on` name) (classes oocd)))
+
+  pict :: Picture
+  pict = (makePicture flags fSpec Plain_CG oocd)
+           {caption = case language flags of
+                        Dutch   -> "Logisch gegevensmodel van "++name fSpec
+                        English -> "Logical data model of "++name fSpec}      
+  oocd :: ClassDiag
+  oocd = cdAnalysis fSpec flags
+  
+  detailsOfClass :: Class -> Blocks
+  detailsOfClass cl = 
+           header (lev+1) ((case language flags of
+                       Dutch   -> text "Gegevensverzameling: "
+                       English -> text "Entity type: "
+                     )
+                     <> (emph.strong.text.name) cl)
+        <> case language flags of 
+             Dutch   -> para $ text "Deze gegevensverzameling bevat de volgende attributen: "
+             English -> para $ text "This entity type has the following attributes: "
+        <> simpleTable (case language flags of
+                          Dutch   -> [(plain.text) "Attribuut"
+                                     ,(plain.text) "Type"
+                                     ,mempty
+                                     ]
+                          English -> [(plain.text) "Attribute"
+                                     ,(plain.text) "Type"
+                                     ,mempty
+                                     ]
+                       )
+                       ( [[ (plain.text) "Id"
+                          , (plain.text.name) cl
+                          , (plain.text) (case language flags of
+                                            Dutch -> "Sleutel"
+                                            English -> "Primary key"
+                                         )
+                         ]]
+                    <> [ [ (plain.text.name) attr
+                         , (plain.text.attTyp) attr
+                         , (plain.text) $ case (language flags,attOptional attr) of
+                                            (Dutch  ,True ) -> "Optioneel"
+                                            (English,True ) -> "Optional"
+                                            (Dutch  ,False) -> "Verplicht"
+                                            (English,False) -> "Mandatory"
+                         ]
+                         | attr <- clAtts cl]
+                       )  
+        <> case language flags of 
+             Dutch   -> para ( text (name cl) <> text " heeft de volgende associaties: ")
+             English -> para ( text (name cl) <> text " has the following associations: ")
+        <> orderedList [assocToRow assoc | assoc <- assocs oocd
+                         , assSrc assoc == root || assTrg assoc == root]
+                       
+    where
+     root = case clcpt cl of
+       Nothing -> fatal 193 "A class in the logical data model should have a root concept."
+       Just c  -> Left c
+     assocToRow :: DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram.Association -> Blocks
+     assocToRow assoc  =                 
+        -- showDummy assoc <>
+        if (null.assrhr) assoc
+        then fatal 192 "Shouldn't happen: flip the relation for the right direction!"
+        else case language flags of
+           Dutch   -> para (   text "Ieder(e) "
+                            <> (emph.text.nm.assSrc) assoc
+                            <> let rel = (singleQuoted.text.assrhr) assoc
+                                   rel' = text ""
+                               in (case assrhm assoc of
+                                     Mult MinZero MaxOne  -> text " "  <> rel <> text " maximaal één " 
+                                     Mult MinZero MaxMany -> text " "  <> rel <> text " geen tot meerdere "
+                                     Mult MinOne  MaxOne  -> text " moet " <> rel <> text " precies één "
+                                     Mult MinOne  MaxMany -> text " moet " <> rel <> text " ten minste één "
+                                  ) 
+                            <> (emph.text.nm.assTrg) assoc 
+                            <> text ". Over deze relatie geldt omgekeerd dat "
+                            <> text "ieder(e) "
+                            <> (emph.text.nm.assTrg) assoc
+                            <> (case asslhm assoc of
+                                     Mult MinZero MaxOne  -> text " "  <> rel' <> text " maximaal één " 
+                                     Mult MinZero MaxMany -> text " "  <> rel' <> text " geen tot meerdere "
+                                     Mult MinOne  MaxOne  -> text " moet " <> rel' <> text " precies één "
+                                     Mult MinOne  MaxMany -> text " moet " <> rel' <> text " ten minste één "
+                                  )
+                            <> (emph.text.nm.assSrc) assoc
+                            <> text " kan hebben."
+                           )
+           English -> para (   text "Every "
+                            <> (emph.text.nm.assSrc) assoc
+                            <> let rel = (singleQuoted.text.assrhr) assoc
+                                   rel' = text ""
+                               in (case assrhm assoc of
+                                     Mult MinZero MaxOne  -> text " "  <> rel <> text " at most one " 
+                                     Mult MinZero MaxMany -> text " "  <> rel <> text " zero or more "
+                                     Mult MinOne  MaxOne  -> text " must " <> rel <> text " exactly one "
+                                     Mult MinOne  MaxMany -> text " must " <> rel <> text " at least one "
+                                  ) 
+                            <> (emph.text.nm.assTrg) assoc 
+                            <> text ". For the other way round, for this relation holds that "
+                            <> text "each "
+                            <> (emph.text.nm.assTrg) assoc
+                            <> (case asslhm assoc of
+                                     Mult MinZero MaxOne  -> text " "  <> rel' <> text " at most one " 
+                                     Mult MinZero MaxMany -> text " "  <> rel' <> text " zero or more "
+                                     Mult MinOne  MaxOne  -> text " must " <> rel' <> text " exactly one "
+                                     Mult MinOne  MaxMany -> text " must " <> rel' <> text " at least one "
+                                  )
+                            <> (emph.text.nm.assSrc) assoc
+                            <> text "."
+                           )
+             
+showDummy :: DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram.Association -> Blocks
+showDummy assoc = --(plain.text.show) assoc 
+        (para.text) ("assSrc: "++(nm.assSrc) assoc)
+     <> (para.text) ("asslhm: "++(show.asslhm) assoc)
+     <> (para.text) ("asslhr: "++(     asslhr) assoc)
+     <> (para.text) ("assTrg: "++(nm.assTrg) assoc)
+     <> (para.text) ("assrhm: "++(show.assrhm) assoc)
+     <> (para.text) ("assrhr: "++(     assrhr) assoc)
+  
+nm x = case x of 
+         Left c  -> name c
+         Right s -> s             
+technicalDataModelSection :: Int -> Fspc -> Options -> (Blocks,[Picture])
+technicalDataModelSection lev fSpec flags = (theBlocks,[pict])
+ where 
+   theBlocks =
+       header lev (case language flags of
+                    Dutch   -> text "Technisch datamodel"
+                    English -> text "Technical datamodel"
+                      )
+    <> para (case language flags of
+               Dutch   -> (text "De afspraken zijn vertaald naar een technisch datamodel. "
+                         <> ( if canXRefer flags
+                              then text "Dit model is in figuur " <> xRefReference flags pict <> text " weergegeven."
+                              else text "Dit model is in onderstaand figuur weergegeven. "
+                          ) )
+               English -> (text "The functional requirements have been translated into a technical data model. "
+                         <> ( if canXRefer flags
+                              then text "This model is shown by figure " <> xRefReference flags pict <> text "."
+                              else text "This model is shown by the figure below. "
+                          ) )
+            )
+    <> para (showImage flags pict)
+    <> para (let nrOfTables = length (filter isTable (plugInfos fSpec)) 
+             in
+             case language flags of
+        Dutch   -> text ("Het technisch datamodel bestaat uit de volgende "++show nrOfTables++" tabellen:")
+        English -> text ("The technical datamodel consists of the following "++show nrOfTables++"tables:")
+            )
+    <> mconcat [detailsOfplug p | p <- sortBy (compare `on` name) (plugInfos fSpec), isTable p]
+    where
+      isTable :: PlugInfo -> Bool
+      isTable (InternalPlug TblSQL{}) = True
+      isTable (InternalPlug BinSQL{}) = True
+      isTable (InternalPlug ScalarSQL{}) = False
+      isTable ExternalPlug{} = False
+      detailsOfplug :: PlugInfo -> Blocks
+      detailsOfplug p = 
+           header 3 (   case (language flags, p) of
+                          (Dutch  , InternalPlug{}) -> text "Tabel: "
+                          (Dutch  , ExternalPlug{}) -> text "Dataservice: "
+                          (English, InternalPlug{}) -> text "Table: "
+                          (English, ExternalPlug{}) -> text "Data service: "
+                     <> text (name p)
+                    ) 
+        <> case p of
+             InternalPlug tbl@TblSQL{} 
+               -> (case language flags of
+                Dutch 
+                   -> para (text $ "Deze tabel heeft de volgende "++(show.length.fields) tbl++" velden:")
+                English 
+                   -> para (text $ "This table has the following "++(show.length.fields) tbl++" fields:")
+                  )
+               <> showFields (plugFields tbl)
+             InternalPlug bin@BinSQL{} 
+               -> para 
+                       (case language flags of
+                         Dutch
+                           ->  text "Dit is een koppeltabel, die "
+                            <> primExpr2pandocMath flags (mLkp bin)
+                            <> text " implementeert. De tabel bestaat uit de volgende kolommen:"      
+                           
+                         English
+                           ->  text "This is a link-table, implementing "
+                            <> primExpr2pandocMath flags (mLkp bin)
+                            <> text ". It contains the following columns:"  
+                       )
+                     <> showFields (plugFields bin)
+                   
+                  
+             InternalPlug ScalarSQL{} 
+                -> mempty
+             ExternalPlug _
+               -> case language flags of
+                    Dutch   -> para (text "De details van deze service zijn in dit document (nog) niet verder uitgewerkt.")
+                    English -> para (text "The details of this dataservice are not available in this document.")
+      showFields :: [SqlField] -> Blocks
+      showFields flds = bulletList (map showField flds)
+        where 
+          eRelIs = [c | EDcI c <- map fldexpr flds]
+          showField fld =
+             let isPrimaryKey = case fldexpr fld of
+                                  fld@EDcI{} -> fld==fldexpr (head flds) -- The first field represents the most general concept
+                                  _          -> False 
+                 mForeignKey  = case fldexpr fld of
+                                  EIsc (EDcI c,_) -> Just c
+                                  _               -> Nothing  
+             in para (  (strong.text.fldname) fld
+                      <> linebreak
+                      <> (if isPrimaryKey 
+                          then case language flags of
+                                Dutch   -> text ("Dit attribuut is de primaire sleutel. ")
+                                English -> text ("This attribute is the primary key. ")
+                          else 
+                          case mForeignKey of 
+                           Just c ->  case language flags of
+                                         Dutch   -> text ("Dit attribuut verwijst naar een voorkomen in de tabel ")
+                                         English -> text ("This attribute is a foreign key to ")
+                                     <> (text.name) c
+                           Nothing -- (no foreign key...)
+                             -> --if isBool
+                                --then 
+                                --else
+                                  (case language flags of
+                                     Dutch   -> text ("Dit attribuut implementeert ")
+                                     English -> text ("This attribute implements ")
+                                  <> primExpr2pandocMath flags (fldexpr fld)
+                                  <> text "."
+                                  )
+                         )
+                      <> linebreak 
+                      <> (code.show.fldtype) fld
+                      <> text ", "
+                      <> (case language flags of
+                            Dutch 
+                              -> text (if fldnull fld then "Optioneel" else "Verplicht")
+                               <>text (if flduniq fld then ", Uniek" else "")
+                               <>text "."
+                            English 
+                              -> text (if fldnull fld then "Optional" else "Mandatory")
+                               <>text (if flduniq fld then ", Unique" else "")
+                               <>text "."
+                         )
+                     )
+   pict :: Picture
+   pict = (makePicture flags fSpec Plain_CG oocd)
+            {caption = case language flags of
+                         Dutch   -> "Technisch gegevensmodel van "++name fSpec
+                         English -> "Technical data model of "++name fSpec}      
+   oocd :: ClassDiag
+   oocd = tdAnalysis fSpec flags
+  
+                   
+             
+daBasicsSection :: Int -> Fspc -> Options -> Blocks
+-- | The function daBasicsSection lists the basic sentences that have been used in assembling the data model.
+daBasicsSection lev fSpec flags = theBlocks
+ where 
+  theBlocks =
+       header lev (case language flags of
+                    Dutch   -> text "Basiszinnen"
+                    English -> text "Fact types"
+                  )
+   <> case language flags of 
+        Dutch   -> para (text "In deze paragraaf worden de basiszinnen opgesomd, die een rol spelen bij het ontwerp van de gegevensstructuur. "
+                       <>text "Per basiszin wordt de naam en het bron- en doelconcept gegeven, alsook de eigenschappen van deze relatie."
+                        )
+        English -> para (text "This section enumerates the fact types, that have been used in the design of the datastructure. "
+                       <>text "For each fact type its name, the source and target concept and the properties are documented."
+                        )       
+   <> definitionList (map toDef declsInRelevantThemes)
+-- HJO, 20130526: onderstaande tabel vervangen door bovenstaande lijst, ivm leesbaarheid.
+--   <>  table 
+--        (-- caption -- 
+--         case language flags of
+--           Dutch   -> text "Deze tabel bevat de basiszinnen, die gebruikt zijn als basis voor de gegevensanalyse."
+--           English -> text "This table lists the fact types, that have been used in assembling the data models."
+--        )
+--        [(AlignLeft,0.4)       , (AlignCenter, 0.4)         , (AlignCenter, 0.2)]
+--        ( case language flags of
+--           Dutch   -> [plain (text "Relatie") , plain (text "Beschrijving"), plain (text "Eigenschappen")]
+--           English -> [plain (text "Relation"), plain (text "Description") , plain (text "Properties")   ]
+--        ) 
+--        (map toRow declsInRelevantThemes)
+    where
+      declsInRelevantThemes = 
+        -- a declaration is considered relevant iff it is declared or used in one of the relevant themes.
+         [d | d<-declarations fSpec
+         , decusr d
+         , (  decpat d `elem` relevantThemes fSpec  
+               || d `elem` declsUsedIn [p | p<-            patterns fSpec   , name p `elem` relevantThemes fSpec]
+               || d `elem` declsUsedIn [p | p<-map fpProc (vprocesses fSpec), name p `elem` relevantThemes fSpec]
+           )
+         ]
+      toRow :: Declaration -> [Blocks]
+      toRow d
+        = [ (plain.math.showMath) d
+          , fromList (meaning2Blocks (language flags) d)
+          , plain ( inlineIntercalate (str ", ") [ text (showADL m) | m <-multiplicities d])
+          ]
+      toDef :: Declaration -> (Inlines, [Blocks])
+      toDef d
+        = ( (math.showMath) d
+          , [   para linebreak
+             <> fromList (meaning2Blocks (language flags) d)
+                   
+          <> para (   ((strong.text) (case language flags of
+                                       Dutch   -> "Eigenschappen"
+                                       English -> "Properties"
+                                    ))
+                   <> text ": "
+                   <> if null (multiplicities d) 
+                      then text "--"
+                      else inlineIntercalate (str ", ") [ text (showADL m) | m <-multiplicities d]
+                  )
+          <> para linebreak
+            ]
+            
+          )
+
+-- The properties of various declarations are documented in different tables.
+-- First, we document the heterogeneous properties of all relations
+-- Then, the endo-poperties are given, and finally
+-- the signals are documented.
+{-
+  daAssociations :: [Relation] -> [Block]
+  daAssociations rs = heteroMultiplicities ++ endoProperties ++ identityDocumentation ++ viewDocumentation
+   where
+    heteroMultiplicities
+     = case [r | r@Rel{}<-rs, not (isProp r), not (isAttribute r)] of
+        []  -> []
+        [r] -> [ case language flags of
+                   Dutch   ->
+                      Para [ Str $ upCap (name fSpec)++" heeft één associatie: "++showADL r++". Deze associatie "++ 
+                                   case (isTot r, isSur r) of
+                                    (False, False) -> "heeft geen beperkingen ten aanzien van multipliciteit."
+                                    (True,  False) -> "is totaal."
+                                    (False, True ) -> "is surjectief."
+                                    (True,  True ) -> "is totaal en surjectief."
+                           ]
+                   English ->
+                      Para [ Str $ upCap (name fSpec)++" has one association: "++showADL r++". This association "++ 
+                                   case (isTot r, isSur r) of
+                                    (False, False) -> "has no restrictions with respect to multiplicities. "
+                                    (True,  False) -> "is total."
+                                    (False, True ) -> "is surjective."
+                                    (True,  True ) -> "is total and surjective."
+                           ]]
+        rs' -> case [r | r<-rs', (not.null) ([Tot,Sur] `isc` multiplicities r) ] of
+               []  -> []
+               [r] -> [ case language flags of
+                          Dutch   ->
+                             Para [ Str $ upCap (name fSpec)++" heeft "++count flags (length rs) "associatie"++". "
+                                  , Str $ " Daarvan is "++showADL r++if isTot r then "totaal" else "surjectief"
+                                  ]
+                          English   ->
+                            Para [ Str $ upCap (name fSpec)++" has "++count flags (length rs) "association"++". "
+                                  , Str $ " Association "++showADL r++" is "++if isTot r then "total" else "surjective"
+                                  ]
+                      ]
+               _   -> [ case language flags of
+                          Dutch   ->
+                             Para [ Str $ upCap (name fSpec)++" heeft de volgende associaties en multipliciteitsrestricties. "
+                                  ]
+                          English   ->
+                             Para [ Str $ upCap (name fSpec)++" has the following associations and multiplicity constraints. "
+                                  ]
+                      , Table [] [AlignLeft,AlignCenter,AlignCenter] [0.0,0.0,0.0]
+                        ( case language flags of
+                          Dutch   ->
+                               [ [Plain [Str "relatie"]]
+                               , [Plain [Str "totaal"]]
+                               , [Plain [Str "surjectief"]]]
+                          English   ->
+                               [ [Plain [Str "relation"]]
+                               , [Plain [Str "total"]]
+                               , [Plain [Str "surjective"]]]
+                        )
+                        [[[Plain [Math InlineMath (showMath r)]] -- r is a relation.
+                         ,[Plain [Math InlineMath "\\surd" | isTot r]]
+                         ,[Plain [Math InlineMath "\\surd" | isSur r]]]
+                        | r<-rs', not (isAttribute r)
+                        ]
+                      ]
+    isAttribute r = (not.null) ([Uni,Inj] `isc` multiplicities r)
+    endoProperties
+     = if null [ m | r<-hMults, m<-multiplicities r, m `elem` [Rfx,Irf,Trn,Sym,Asy]]
+       then []
+       else [ Para (case language flags of
+                          Dutch   ->
+                            [Str "Er is één endorelatie, ", Math InlineMath (showMath d), Str " met de volgende eigenschappen: "]
+                          English   ->
+                            [Str "There is one endorelation, ", Math InlineMath (showMath d), Str " with the following properties: "] )
+            | length hMults==1, d<-hMults ]++
+            [ Para [ case language flags of
+                          Dutch   ->
+                            Str "In aanvulling daarop hebben de endorelaties de volgende eigenschappen: "
+                          English   ->
+                            Str "Additionally, the endorelations come with the following properties: "]
+            | length hMults>1 ]++
+            [Table [] [AlignLeft,AlignCenter,AlignCenter,AlignCenter,AlignCenter,AlignCenter,AlignCenter] [0.0,0.0,0.0,0.0,0.0,0.0,0.0]
+             [[case language flags of
+                          Dutch   -> Plain [Str "relatie"] 
+                          English -> Plain [Str "relation"]  ]
+             ,[Plain [Str "Rfx"]]
+             ,[Plain [Str "Irf"]]
+             ,[Plain [Str "Trn"]]
+             ,[Plain [Str "Sym"]]
+             ,[Plain [Str "Asy"]]
+             ,[Plain [Str "Prop"]]]
+             [[[Plain [Math InlineMath (showMath d)]] -- d is a declaration, and therefore typeable. So  showMath d  exists.
+              ,[Plain [Math InlineMath "\\surd" | isRfx d ]]
+              ,[Plain [Math InlineMath "\\surd" | isIrf d ]]
+              ,[Plain [Math InlineMath "\\surd" | isTrn d ]]
+              ,[Plain [Math InlineMath "\\surd" | isSym d ]]
+              ,[Plain [Math InlineMath "\\surd" | isAsy d ]]
+              ,[Plain [Math InlineMath "\\surd" | isAsy d && isSym d ]]]
+             | d<-hMults]
+            | length hMults>0 ]
+       where
+        hMults :: [Declaration]
+        hMults  = [decl | decl@Sgn{}<- declsUsedIn fSpec, isEndo decl
+                        , null (themes fSpec) || decpat decl `elem` themes fSpec]
+    identityDocumentation
+     = case (identities fSpec, language flags) of
+        ([], _)              -> []
+        ([k], Dutch)         -> [ Para  [Str "Er is één identiteit: ",Str (name k),Str "."]]
+        ([k], English)       -> [ Para  [Str "There is but one identity: ",Str (name k),Str "." ]]
+        (identities, Dutch)  -> [ Para $ Str "De volgende identiteiten bestaan: ": commaNLPandoc (Str "en") [Str (name i) | i<-identities]]
+        (identities, English)-> [ Para $ Str "The following identities exist: ": commaEngPandoc (Str "and") [Str (name i) | i<-identities]]
+
+    viewDocumentation
+     = case (viewDefs fSpec, language flags) of
+        ([], _) -> []
+        ([v], Dutch)   -> [ Para  [Str "Er is één view: ",Str (name v),Str "."]]
+        ([v], English) -> [ Para  [Str "There is but one view: ",Str (name v),Str "." ]]
+        (viewds, Dutch) -> [ Para $ Str "De volgende views bestaan: ": commaNLPandoc (Str "en") [Str (name v) | v<-viewds]]
+        (viewds, English)->[ Para $ Str "The following views exist: ": commaEngPandoc (Str "and") [Str (name v) | v<-viewds]]
+
+-}
+-- The properties of various declations are documented in different tables.
+-- First, we document the heterogeneous properties of all relations
+-- Then, the endo-poperties are given, and finally
+-- the process rules are documented.
+
+  daAttributes :: PlugSQL -> [Block]
+  daAttributes p
+   = if length (plugFields p)<=1 then [] else
+     [ case language flags of
+               Dutch   ->
+                 Para [ Str $ "De attributen van "++name p++" hebben de volgende multipliciteitsrestricties. "
+                 ]
+               English ->
+                 Para [ Str $ "The attributes in "++name p++" have the following multiplicity constraints. "
+                 ]
+     ,Table [] [AlignLeft,AlignLeft,AlignCenter,AlignCenter] [0.0,0.0,0.0,0.0]
+      ( case language flags of
+          Dutch   ->
+             [[Plain [Str "attribuut"]]
+             ,[Plain [Str "type"]]
+             ,[Plain [Str "verplicht"]]
+             ,[Plain [Str "uniek"]]]
+          English ->
+             [[Plain [Str "attribute"]]
+             ,[Plain [Str "type"]]
+             ,[Plain [Str "mandatory"]]
+             ,[Plain [Str "unique"]]] )
+      [ if isProp (fldexpr fld) && fld/=head (plugFields p)
+        then [ [Plain [Str (fldname fld)]]
+             , [Plain [ Str "Bool"]]
+             , [Plain [Math InlineMath "\\surd"]]
+             , []
+             ]
+        else [ [Plain [if fld==head (plugFields p) || null ([Uni,Inj,Sur]>-multiplicities (fldexpr fld))
+                       then Str  "key "
+                       else Str (fldname fld)]]
+             , [Plain [ (Str . latexEscShw.name.target.fldexpr) fld]]
+             , [Plain [Math InlineMath "\\surd" | not (fldnull fld)]]
+             , [Plain [Math InlineMath "\\surd" | flduniq fld]]
+             ]
+      | fld<-plugFields p  -- tail haalt het eerste veld, zijnde I[c], eruit omdat die niet in deze tabel thuishoort.
+      ]
+      
+     ]
+-- the endo-properties have already been reported in the general section of this chapter.
+{-     where
+--  voorgestelde multipliciteitenanalyse....
+      clauses = nub [clause | Quad _ ccrs<-vquads fSpec, (_,dnfClauses)<-cl_conjNF ccrs, clause<-dnfClauses]
+      is = nub [r | EUni fus<-clauses
+                  , isIdent (EIsc [notCpl f | f<-fus, isPos f] sgn)
+                  , f<-filter isNeg fus
+                  , s<-strands f
+                  , e<-[head s, flp (last s)]
+                  , r<-declsUsedIn e
+                ]
+      ts = nub [r | EUni fus<-clauses
+                  , isIdent (EIsc [notCpl f | f<-fus, isNeg f] sgn)
+                  , f<-filter isPos fus
+                  , s<-strands f
+                  , e<-[head s, flp (last s)]
+                  , r<-declsUsedIn e
+                  ]
+      strands (ECps fs) = [fs]
+      strands _      = []    -- <--  we could maybe do better than this...
+      tots = [d | t<-ts, inline t, d<-map makeDeclaration (declsUsedIn t)]
+      unis = [d | t<-is, inline t, d<-map makeDeclaration (declsUsedIn t)]
+      surs = [d | t<-ts, not (inline t), d<-map makeDeclaration (declsUsedIn t)]
+      injs = [d | t<-is, not (inline t), d<-map makeDeclaration (declsUsedIn t)]
+-}
+
+  -- daPlugs describes data sets.
+  -- These can be recognized by:
+  --    1. the first field has the "unique" attribute on (otherwise it is a binary association)
+  --    2. there is more than one field (otherwise it is a scalar).
+  -- The text gives all rules that are maintained internally within the data structure,
+  -- because they might very well be implemented as database integrity rules.
+  -- Multiplicity rules are not reported separately, because they are already taken care of in the multiplicity tables.
+  -- Plugs that are associations between data sets and scalars are ignored.
+
+  daPlug :: PlugSQL -> [Block]
+  daPlug p
+   = if null content then [] else plugHeader ++ content
+     where
+       thing2block r = pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
+       plugHeader = toList $ labeledThing flags (lev+1) ("sct:Plug "++escapeNonAlphaNum (name p)) (name p)
+       content = daAttributes p ++ plugRules ++ plugSignals ++ plugIdentities ++ iRules
+       plugRules
+        = case language flags of
+           English -> case [r | r<-invariants fSpec, null (declsUsedIn r >- declsUsedIn p)] of
+                       []  -> []
+                       [r] -> [ Para [ Str "Within this data set, the following integrity rule shall be true at all times. " ]]++
+                              if showPredExpr flags
+                              then pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
+                              else [ Para [ Math DisplayMath $ showMath r]]
+                       rs  -> [ Para [ Str "Within this data set, the following integrity rules shall be true at all times. " ]
+                              , if showPredExpr flags
+                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel r) . showLatex . toPredLogic) r | r<-rs ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath r]] | r<-rs ]
+                              ]
+           Dutch   -> case [r | r<-invariants fSpec, null (declsUsedIn r >- declsUsedIn p)] of
+                       []  -> []
+                       [r] -> [ Para [ Str "Binnen deze gegevensverzameling dient de volgende integriteitsregel te allen tijde waar te zijn. " ]]++
+                              if showPredExpr flags
+                              then pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
+                              else [ Para [ Math DisplayMath $ showMath r]]
+                       rs  -> [ Para [ Str "Binnen deze gegevensverzameling dienen de volgende integriteitsregels te allen tijde waar te zijn. " ]
+                              , if showPredExpr flags
+                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel r) . showLatex . toPredLogic) r | r<-rs ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath r]] | r<-rs ]
+                              ]
+       plugIdentities
+        = case language flags of
+           English -> case [k | k<-identityRules fSpec, null (declsUsedIn k >- declsUsedIn p)] of
+                       []  -> []
+                       [s] -> [ Para [ Str "This data set contains one key. " ]]++
+                              if showPredExpr flags
+                              then pandocEqnArrayOnelabel (symDefLabel s) ((showLatex.toPredLogic) s)
+                              else [ Para [ Math DisplayMath $ showMath s]]
+                       ss  -> [ Para [ Str "This data set contains the following keys. " ]
+                              , if showPredExpr flags
+                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel s) . showLatex . toPredLogic) s | s<-ss ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath s]]
+                                                | s<-ss ]
+                              ]
+           Dutch   -> case [k | k<-identityRules fSpec, null (declsUsedIn k >- declsUsedIn p)] of
+                       []  -> []
+                       [s] -> [ Para [ Str ("Deze gegevensverzameling genereert één key. ") ]]++
+                              if showPredExpr flags
+                              then pandocEqnArrayOnelabel (symDefLabel s) ((showLatex.toPredLogic) s)
+                              else [ Para [ Math DisplayMath $ showMath s]]
+                       ss  -> [ Para [ Str "Deze gegevensverzameling genereert de volgende keys. " ]
+                              , if showPredExpr flags
+                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel s) . showLatex . toPredLogic) s | s<-ss ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath s]] | s<-ss ]
+                              ]
+       plugSignals
+        = case (language flags, [r | r<-vrules fSpec, isSignal r , null (declsUsedIn r >- declsUsedIn p)]) of
+    --       English -> case [r | r<-vrules fSpec, isSignal r , null (declsUsedIn r >- declsUsedIn p)] of
+            (_      , [])  -> []
+            (English, [s]) -> [ Para [ Str "This data set generates one process rule. " ]]++
+                              if showPredExpr flags
+                              then pandocEqnArrayOnelabel (symDefLabel s) ((showLatex.toPredLogic) s)
+                              else [ Para [ Math DisplayMath $ showMath s]]
+            (English, ss)  -> [  Para [ Str "This data set generates the following process rules. " ]
+                              , if showPredExpr flags
+                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel s) . showLatex . toPredLogic) s | s<-ss ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath s]] | s<-ss ]
+                              ]
+            (Dutch  , [s]) -> [ Para [ Str ("Deze gegevensverzameling genereert één procesregel. ") ]]++
+                              if showPredExpr flags
+                              then pandocEqnArrayOnelabel (symDefLabel s) ((showLatex.toPredLogic) s)
+                              else [ Para [ Math DisplayMath $ showMath s]]
+            (Dutch  , ss ) -> [ Para [ Str "Deze gegevensverzameling genereert de volgende procesregels. " ]
+                              , if showPredExpr flags
+                                then BulletList [(pandocEqnArrayOnelabel (symDefLabel s) . showLatex . toPredLogic) s | s<-ss ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath s]] | s<-ss ]
+                              ]
+       iRules
+        = case language flags of
+           English -> case irs of
+                       []  -> []
+                       [e] -> [ Para [ Str "The following rule defines the integrity of data within this data set. It must remain true at all times. " ]]++
+                              if showPredExpr flags
+                              then pandocEqnArrayOnelabel "" ((showLatex.toPredLogic) e)
+                              else [ Para [ Math DisplayMath $ showMath e]]
+                       es  -> [ Para [ Str "The following rules define the integrity of data within this data set. They must remain true at all times. " ]
+                              , if showPredExpr flags
+                                then BulletList [(pandocEqnArrayOnelabel "" . showLatex . toPredLogic) e | e<-es ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath e]] | e<-es ]
+                              ]
+           Dutch   -> case irs of
+                       []  -> []
+                       [e] -> [ Para [ Str "De volgende regel definieert de integriteit van gegevens binnen deze gegevensverzameling. Hij moet te allen tijde blijven gelden. "]]++
+                              if showPredExpr flags
+                              then pandocEqnArrayOnelabel "" ((showLatex.toPredLogic) e)
+                              else [ Para [ Math DisplayMath $ showMath e]]
+                       es  -> [ Para [ Str "De volgende regels definiëren de integriteit van gegevens binnen deze gegevensverzameling. Zij moeten te allen tijde blijven gelden. " ]
+                              , if showPredExpr flags
+                                then BulletList [(pandocEqnArrayOnelabel "" . showLatex . toPredLogic) e | e<-es ]
+                                else BulletList [ [Para [Math DisplayMath $ showMath e]] | e<-es ]
+                              ]
+          where irs = [ dnf2expr dc
+                      | Quad r ccrs<-vquads fSpec
+                      , r_usr (cl_rule ccrs)==UserDefined, isIdent r, source r `elem` pcpts
+                      , x<-cl_conjNF ccrs
+                      , dc@(Dnf [EDcD nega] _)<-rc_dnfClauses x
+                      , r==nega
+                      ]
+                pcpts = case p of
+                  ScalarSQL{} -> [cLkp p]
+                  _           -> map fst (cLkpTbl p)
+
+primExpr2pandocMath :: Options -> Expression -> Inlines
+primExpr2pandocMath flags e =
+ case e of
+  (EDcD d ) ->  
+           case language flags of
+             Dutch -> text "de relatie " 
+             English -> text "the relation "
+        <> math ((name.source) d++ " \\xrightarrow {"++name d++"} "++(name.target) d)
+  (EFlp (EDcD d)) -> 
+           case language flags of
+             Dutch -> text "de relatie " 
+             English -> text "the relation "
+        <> math ((name.source) d++ " \\xleftarrow  {"++name d++"} "++(name.target) d)
+  (EIsc (r1,_)) -> 
+           let srcTable = case r1 of
+                            EDcI c -> c
+                            _      -> fatal 767 ("Unexpected expression: "++show r1)
+           in 
+           case language flags of
+             Dutch -> text "de identiteitsrelatie van " 
+             English -> text "the identityrelation of "
+        <> math (name srcTable)
+  (EDcI c) ->
+            case language flags of
+             Dutch -> text "de identiteitsrelatie van " 
+             English -> text "the identityrelation of "
+        <> math (name c)
+  _   -> fatal 223 ("Have a look at the generated Haskell to see what is going on..\n"++show e) 
+  
+  
+  
+-- | The user can specify that only specific themes should be taken into account 
+--   in the output. However, when no themes are specified, all themes are relevant.
+relevantThemes :: Fspc -> [String]
+relevantThemes fSpec = if null (themes fSpec)
+                       then map name (patterns fSpec) ++ map name (vprocesses fSpec)
+                       else themes fSpec
+  
+                          
+
+ src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs view
@@ -0,0 +1,823 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDiagnosis 
+where
+import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
+import DatabaseDesign.Ampersand.ADL1
+import DatabaseDesign.Ampersand.Classes
+import Data.List
+import DatabaseDesign.Ampersand.Output.PandocAux
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.ChapterDiagnosis"
+
+chpDiagnosis :: Fspc -> Options -> (Blocks,[Picture])
+chpDiagnosis fSpec flags
+ = ( fromList $
+     header ++                -- the chapter header
+     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 are missing
+     missingRels ++           -- tells which relation declarations are missing
+     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
+  header :: [Block]
+  header = toList (chptHeader flags Diagnosis)
+  diagIntro :: [Block]
+  diagIntro = 
+    case language flags 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 (fRoleRuls fSpec) && null(fRoleRels fSpec) = 
+        case language flags 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 language flags of
+          Dutch    -> [Para [ Str $ upCap (name fSpec)++" kent geen procesregels. " ]]
+          English  -> [Para [ Str $ upCap (name fSpec)++" does not define any process rules. " ]]
+    | otherwise =
+        (case language flags 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 |_<-rs])
+        (0.0:[0.0 |_<-rs])
+        (( case language flags of
+          Dutch   -> [Plain [Str "regel"]] 
+          English -> [Plain [Str "rule" ]] 
+        ) :    [ [Plain [Str r]] | r <- rs ]
+        )
+        [ [Plain [Str (name rul)]]:[f r rul | r<-rs] | rul<-ruls ] 
+        ]
+     where
+      rs = nub ( [r | (r,_) <- fRoleRuls fSpec]++
+                 [r | (r,_) <- fRoleRels fSpec] )
+      ruls = if null (themes fSpec)
+             then [r | r<-vrules fSpec, isSignal r ]
+             else [r | pat<-patterns   fSpec, name pat `elem` themes fSpec, r<-udefrules pat,         isSignal r ] ++
+                  [r | prc<-vprocesses fSpec, name prc `elem` themes fSpec, r<-udefrules (fpProc prc) , isSignal r ]
+      f r rul | (r,rul) `elem` maintained      = [Plain [Math InlineMath "\\surd"]]
+              | (r,rul) `elem` dead            = [Plain [Math InlineMath "\\times"]]
+              | (r,rul) `elem` fRoleRuls fSpec = [Plain [Math InlineMath "\\odot"]]
+              | otherwise                      = []
+      maintained  -- (r,rul) `elem` maintained means that r can maintain rul without restrictions.
+        = [ (role,rul)
+          | (role,rul)<-fRoleRuls fSpec
+          , and (map (mayEdit role) (declsUsedIn rul))
+          ]
+      mayEdit :: String -> Declaration -> Bool
+      mayEdit role decl = decl `elem` ((snd.unzip) (filter (\x -> role == fst x) (fRoleRels fSpec))) 
+      dead -- (r,rul) `elem` dead means that r cannot maintain rul without restrictions.
+       = [ (role,rul)
+         | (role,rul)<-fRoleRuls fSpec
+         , (not.or) (map (mayEdit role) (declsUsedIn rul))
+         ]
+
+  roleomissions :: [Block]
+  roleomissions
+   = if      null  (themes fSpec) && (not.null) (vprocesses fSpec) ||
+        (not.null) (themes fSpec) && (not.null) (themes fSpec `isc` [name prc | prc<-vprocesses fSpec])
+     then [ case language flags of
+              Dutch   ->
+                Plain [ Str $ upCap (name fSpec)++" kent geen regels aan rollen toe. "
+                       , Str "Een generieke rol, User, zal worden gedefinieerd om al het werk te doen wat in het bedrijfsproces moet worden uitgevoerd."
+                       ]
+              English ->
+                Plain [ Str $ upCap (name fSpec)++" does not assign rules to roles. "
+                       , Str "A generic role, User, will be defined to do all the work that is necessary in the business process."
+                       ]
+          | (null.fRoleRuls) fSpec && (not.null.udefrules) fSpec] ++
+          [ case language flags 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 (language flags, 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 <- cptdf c
+                      , null (purposesDefinedIn fSpec (language flags) cd)
+                   ]++
+                   [c | c <-ccs
+                      , null (cptdf c)
+                   ]
+         ccs = concs [ d | d<-declarations fSpec, null (themes fSpec)||decpat d `elem` themes fSpec]  -- restrict if the documentation is partial.
+  unusedConceptDefs :: [Block]
+  unusedConceptDefs
+   = case (language flags, unused) of
+      (Dutch,[])  -> [Para
+                       [Str "Alle conceptdefinities in dit document worden gebruikt in relaties."]
+                     | (not.null.vConceptDefs) fSpec]
+      (Dutch,[c]) -> [Para
+                       [Str "Het concept ", Quoted SingleQuote [Str (name c)], Str " is gedefinieerd, maar wordt niet gebruikt."]
+                     ]
+      (Dutch,xs)  -> [Para $
+                       [Str "De concepten: "]++commaNLPandoc (Str "en") (map (Str . name) xs)++[Str " zijn gedefinieerd, maar worden niet gebruikt."]
+                     ]
+      (English,[])  -> [Para 
+                        [Str "All concept definitions in this document are used in relations."]
+                     | (not.null.vConceptDefs) 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 <-vConceptDefs fSpec, name cd `notElem` map name (allConcepts fSpec)]
+         
+    
+  
+  missingRels :: [Block]
+  missingRels
+   = case (language flags, missing) of
+      (Dutch,[])  -> [Para 
+                       [Str "Alle relaties in dit document zijn voorzien van een reden van bestaan (purpose)."]
+                     | (not.null.declsUsedIn.udefrules) fSpec]
+      (Dutch,[r]) -> [Para 
+                       [ Str "De reden waarom relatie ", r
+                       , Str " bestaat wordt niet uitgelegd."
+                     ] ]
+      (Dutch,rs)  -> [Para $
+                       [ Str "Relaties "]++commaNLPandoc (Str "en") rs++
+                       [ Str " zijn niet voorzien van een reden van bestaan (purpose)."
+                     ] ]
+      (English,[])  -> [Para 
+                         [Str "All relations in this document have been provided with a purpose."]
+                       | (not.null.declsUsedIn.udefrules) fSpec]
+      (English,[r]) -> [Para 
+                         [ Str "The purpose of relation ", r
+                         , Str " remains unexplained."
+                       ] ]
+      (English,rs)  -> [Para $
+                         [ Str "The purpose of relations "]++commaEngPandoc (Str "and") rs++
+                         [ Str " is not documented."
+                       ] ]
+     where missing = [(Math InlineMath . showMath) (EDcD d) 
+                     | d@Sgn{} <-if null (themes fSpec)
+                                 then declsUsedIn fSpec
+                                 else declsUsedIn [pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++
+                                      declsUsedIn [fpProc prc | prc<-vprocesses fSpec, name prc `elem` themes fSpec]
+                     , not (isIdent d)
+                     , null (purposesDefinedIn fSpec (language flags) d)
+                     ]
+
+  relsNotUsed :: [Block]
+  pics :: [Picture]
+  (relsNotUsed,pics)
+   = ( ( case (language flags, notUsed) of
+          (Dutch,[])  -> [Para 
+                           [Str "Alle relaties in dit document worden in één of meer regels gebruikt."]
+                         | (not.null.declsUsedIn.udefrules) fSpec]
+          (Dutch,[r]) -> [Para 
+                           [ Str "De relatie ", r
+                           , Str " wordt in geen enkele regel gebruikt. "
+                         ] ]
+          (Dutch,rs)  -> [Para $
+                           [ Str "Relaties "]++commaNLPandoc (Str "en") rs++
+                           [ Str " worden niet gebruikt in regels. "
+                         ] ]
+          (English,[])  -> [Para 
+                             [Str "All relations in this document are being used in one or more rules."]
+                           | (not.null.declsUsedIn.udefrules) fSpec]
+          (English,[r]) -> [Para 
+                             [ Str "Relation ", r
+                             , Str " is not being used in any rule. "
+                           ] ]
+          (English,rs)  -> [Para $
+                             [ Str "Relations "]++commaEngPandoc (Str "and") rs++
+                             [ Str " are not used in any rule. "
+                           ] ] ) ++
+       ( case (language flags, pictsWithUnusedRels) of
+          (Dutch,[pict])     -> [ Para [ Str "Figuur "
+                                       , xrefReference pict
+                                       , Str " geeft een conceptueel diagram met alle relaties."
+                                       ] 
+                                , Plain (xrefFigure1 pict)
+                                ]
+          (English,[pict])   -> [ Para [ Str "Figure "
+                                       , xrefReference pict
+                                       , Str " shows a conceptual diagram with all relations."
+                                       ]
+                                , Plain (xrefFigure1 pict)
+                                ]
+          (Dutch,picts)   -> concat
+                                  [ Para [ Str "Figuur "
+                                         , xrefReference pict
+                                         , Str " geeft een conceptueel diagram met alle relaties die gedeclareerd zijn in "
+                                         , Quoted SingleQuote [Str (name pat)]
+                                         , Str "."
+                                         ] 
+                                    : [Plain (xrefFigure1 pict)]
+                                  | (pict,pat)<-zip picts pats ]
+          (English,picts) -> concat
+                                  [ Para [ Str "Figure "
+                                         , xrefReference pict
+                                         , Str " shows a conceptual diagram with all relations declared in "
+                                         , Quoted SingleQuote [Str (name pat)]
+                                         , Str "."
+                                         ]
+                                    : [Plain (xrefFigure1 pict)]
+                                  | (pict,pat)<-zip picts pats ] )
+       , pictsWithUnusedRels           -- draw the conceptual diagram
+     )
+     where notUsed = nub [(Math InlineMath . showMath) (EDcD d)
+                         | d@Sgn{} <- declarations fSpec
+                         , null (themes fSpec) || decpat d `elem` themes fSpec  -- restrict if the documentation is partial.
+                         , decusr d
+                         , d `notElem` (declsUsedIn . udefrules) fSpec
+                         ]
+           pats  = [ pat | pat<-patterns fSpec
+                         , null (themes fSpec) || name pat `elem` themes fSpec  -- restrict if the documentation is partial.
+                         , (not.null) (declarations pat>-declsUsedIn pat) ]
+           pictsWithUnusedRels = [makePicture flags fSpec Rel_CG pat | pat<-pats ]
+
+  missingRules :: [Block]
+  missingRules
+   = case (language flags, missingPurp, missingMeaning) of
+      (Dutch,[],[])    -> [ Para [Str "Alle regels in dit document zijn voorzien van een uitleg."]
+                          | (length.udefrules) fSpec>1]
+      (Dutch,rs,rs')   -> [Para 
+                           (case rs>-rs' of
+                              []  -> []
+                              [r] -> [ Str "De bestaansreden van regel ", Emph [Str (name r)]
+                                     , Str (" op regelnummer "++ln r++" van bestand "++fn r)
+                                     , Str " wordt niet uitgelegd. "
+                                     ]
+                              rls -> (upC . commaNLPandoc (Str "en")  )
+                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
+                                         strconcat ([Str ("op regelnummer"++(if length nrs>1 then "s" else "")++" ")]++
+                                                    commaNLPandoc (Str "en") nrs++
+                                                    [Str " van bestand "]++[(Str . locnm . head) cl])
+                                        | cl<-eqCl locnm (map origin rls)] ++
+                                       [ Str " worden regels gedefinieerd, waarvan de bestaansreden niet wordt uitgelegd. " ]
+                            ++
+                            case rs'>-rs of
+                              []  -> []
+                              [r] -> [ Str "De betekenis van regel ", Emph [Str (name r)]
+                                     , Str (" op regelnummer "++ln r++" van bestand "++fn r)
+                                     , Str " wordt uitgelegd in taal die door de computer is gegenereerd. "
+                                     ]
+                              rls -> (upC . commaNLPandoc (Str "en")  )
+                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
+                                         strconcat ([Str ("op regelnummer"++(if length nrs>1 then "s" else "")++" ")]++
+                                                    commaNLPandoc (Str "en") nrs++
+                                                    [Str " van bestand "]++[(Str . locnm . head) cl])
+                                        | cl<-eqCl locnm (map origin rls)] ++
+                                       [ Str " staan regels, waarvan de betekenis wordt uitgelegd in taal die door de computer is gegenereerd. " ]
+                            ++
+                            case rs `isc` rs' of
+                              []  -> []
+                              [r] -> [ Str "Regel ", Emph [Str (name r)]
+                                     , Str (" op regelnummer "++ln r++" van bestand "++fn r++" wordt niet uitgelegd. ")
+                                     ]
+                              rls -> (upC . commaNLPandoc (Str "en")  )
+                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
+                                         strconcat ([Str ("op regelnummer"++(if length nrs>1 then "s" else "")++" ")]++
+                                                    commaNLPandoc (Str "en") nrs++
+                                                    [Str " van bestand "]++[(Str . locnm . head) cl])
+                                        | cl<-eqCl locnm (map origin rls)] ++
+                                       [ Str " worden regels gedefinieerd, zonder verdere uitleg. " ]
+                           )
+                          ]
+      (English,[],[])  -> [ Para [Str "All rules in this document have been provided with a meaning and a purpose."]
+                          | (length.udefrules) fSpec>1]
+      (English,rs,rs') -> [Para $
+                           ( case rs>-rs' of
+                              []  -> []
+                              [r] -> [ Str "The purpose of rule ", Emph [Str (name r)]
+                                     , Str (" on line "++ln r++" of file "++fn r)
+                                     , Str " is not documented. "
+                                     ]
+                              rls -> (upC . commaEngPandoc (Str "and") )
+                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
+                                         strconcat ([ Str ("on line number"++(if length nrs>1 then "s" else "")++" ")]++
+                                                    commaEngPandoc (Str "and") nrs ++
+                                                    [Str " of file "]++[(Str . locnm . head) cl])
+                                        | cl<-eqCl locnm (map origin rls)] ++
+                                       [ Str " rules are defined without documenting their purpose. " ]
+                           ) ++
+                           ( case rs'>-rs of
+                              []  -> []
+                              [r] -> [ Str "The meaning of rule ", Emph [Str (name r)]
+                                     , Str (" on line "++ln r++" of file "++fn r)
+                                     , Str " is documented by means of computer generated language. "
+                                     ]
+                              rls -> (upC . commaEngPandoc (Str "and") )
+                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
+                                         strconcat ([ Str ("on line number"++(if length nrs>1 then "s" else "")++" ")]++
+                                                    commaEngPandoc (Str "and") nrs ++
+                                                    [Str " of file "]++[(Str . locnm . head) cl])
+                                        | cl<-eqCl locnm (map origin rls)] ++
+                                       [ Str " rules are defined, the meaning of which is documented by means of computer generated language. " ]
+                           ) ++
+                           ( case rs `isc` rs' of
+                              []  -> []
+                              [r] -> [ Str "Rule ", Emph [Str (name r)]
+                                     , Str (" on line "++ln r++" of file "++fn r++" is not documented. ")
+                                     ]
+                              rls -> (upC . commaEngPandoc (Str "and") )
+                                        [let nrs = [(Str . show . linenr) l | l<-cl] in
+                                         strconcat ([ Str ("on line number"++(if length nrs>1 then "s" else "")++" ")]++
+                                                    commaEngPandoc (Str "and") nrs ++
+                                                    [Str " of file "]++[(Str . locnm . head) cl])
+                                        | cl<-eqCl locnm (map origin rls)] ++
+                                       [ Str " rules are defined without any explanation. " ]
+                           )
+                          ]
+     where missingPurp
+            = nub [ r
+                  | r<-ruls
+                  , null (purposesDefinedIn fSpec (language flags) r)
+                  ]
+           missingMeaning
+            = nub [ r
+                  | r<-ruls
+                  , null [m | m <- ameaMrk (rrmean r), amLang m == language flags]
+                  ]
+           ruls = if null (themes fSpec)
+                  then udefrules fSpec
+                  else concat [udefrules pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++
+                       concat [udefrules (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec]
+           upC (Str str:strs) = Str (upCap str):strs
+           upC str = str
+           fn r = locnm (origin r)
+           ln r = locln (origin r)
+           strconcat :: [Inline] -> Inline
+           strconcat strs = (Str . concat) [ str | Str str<-strs]
+
+  ruleRelationRefTable =
+    [ Para [ Str descriptionStr ]
+    , Table [] (AlignLeft : replicate 6 AlignCenter) [0.0,0.0,0.0,0.0,0.0,0.0,0.0] 
+            (map strCell [ themeStr, relationsStr, withRefStr, "%", rulesStr, withRefStr, "%"])
+            (map mkTableRowPat (vpatterns fSpec) ++ map mkTableRowProc (vprocesses fSpec) ++ 
+            [[]] ++ -- empty row
+            [mkTableRow contextStr (filter decusr $ vrels fSpec) (vrules fSpec)])
+    ]
+    where mkTableRowPat p = mkTableRow (name p) (ptdcs p) (ptrls p)
+          mkTableRowProc (FProc p _) = mkTableRow (name p) (prcDcls p) (prcRules p) 
+          mkTableRow nm decls ruls = 
+            let nrOfRels = length decls
+                nrOfRefRels = length $ filter hasRef decls
+                nrOfRules = length ruls
+                nrOfRefRules = length $ filter hasRef ruls
+            in  map strCell [ nm
+                            , show nrOfRels, show nrOfRefRels, showPercentage nrOfRels nrOfRefRels
+                            , show nrOfRules, show nrOfRefRules, showPercentage nrOfRules nrOfRefRules 
+                            ]
+        
+          hasRef x = maybe False (any  ((/="").explRefId)) (purposeOf fSpec (language flags) x)
+          
+          showPercentage x y = if x == 0 then "-" else show (y*100 `div` x)++"%" 
+          
+          strCell str = [Plain [Str str]]
+          
+          (descriptionStr, themeStr, relationsStr, withRefStr, rulesStr, contextStr) = 
+            case (language flags) 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 (language flags, 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 language flags of
+          Dutch   -> [ [Plain [Str "proces" ]] , [Plain [Str "regel"]] ]
+          English -> [ [Plain [Str "process"]] , [Plain [Str "rule" ]] ]
+       )
+       [ [[Plain [Str (name p)]], [Plain (intercalate [Str ", "] [[Str (name r)] | r<-rs])]]
+       | (p,rs)<-prs
+       ]
+     | not (null prs)]
+     where prs = [(fp,rs) | fp<-procs
+                          , let rs=invariants (fpProc fp), not (null rs) ]
+           procs = if null (themes fSpec) then vprocesses fSpec else [prc | prc<-vprocesses fSpec, name prc `elem` themes fSpec ]
+
+  processrulesInPatterns :: [Block]
+  processrulesInPatterns
+   = [ case (language flags, procs,prs) of
+        (Dutch,  [p],[])  -> Para [ Str "Alle rol-regel-koppelingen gaan over regels die binnen proces ", Quoted SingleQuote [Str (name p)], Str " gedefinieerd zijn. " ]
+        (English,[p],[])  -> Para [ Str "All role-rule assigments involve rules that are defined in process ", Quoted SingleQuote [Str (name p)], Str ". " ]
+        (Dutch,  _,[])    -> Para [ Str "Voor elk proces geldt dat alle rol-regel-koppelingen gaan over regels die binnen dat proces zijn gedefinieerd." ]
+        (English,_,[])    -> Para [ Str "The role-rule assignments in any of the described processes have been assigned to rules within that same process." ]
+        (Dutch,  _,[(p,rol,rul)])
+                          -> Para [ Str "Er is één koppeling tussen een rol en een regel van buiten het proces: "
+                                  , Str "Rol ", Quoted SingleQuote [Str rol], Str " uit proces ", Quoted SingleQuote [Str (name p)], Str " is gebonden aan regel ", Quoted SingleQuote [Str (name rul)], Str " uit ", Quoted SingleQuote [Str (r_env rul)], Str "."
+                                  ]
+        (English,_,[(p,rol,rul)])
+                          -> Para [ Str "There is one role that is assigned to a rule outside the process: "
+                                  , Str "Role ", Quoted SingleQuote [Str rol], Str ", defined in process ", Quoted SingleQuote [Str (name p)], Str ", is assigned to rule ", Quoted SingleQuote [Str (name rul)], Str " from ", Quoted SingleQuote [Str (r_env rul)], Str "."
+                                  ]
+        (Dutch,  [p],_)   -> Para [ Str "De volgende tabel toont welke regels in welke patterns aan een rol gekoppeld zijn. "
+                                  , Str "Dit heeft als consequentie dat de computer de betreffende regel(s) in proces ", Quoted SingleQuote [Str (name p)], Str " zal handhaven. "
+                                  ]
+        (English,[p],_)   -> Para [ Str "The following table shows which rules from outside the process are linked to a role in the process. "
+                                  , Str "This has as consequence that these rule(s) will be maintained in the corresponding process ", Quoted SingleQuote [Str (name p)], Str ". "
+                                  ]
+        (Dutch,  _,_)     -> Para [ Str "Er zijn koppelingen tussen rollen en regels, die buiten de grenzen van het proces reiken. "
+                                  , Str "De volgende tabel toont welke regels in welke patterns aan een rol gekoppeld zijn. "
+                                  , Str "Dit heeft als consequentie dat de computer de betreffende regel(s) in de bijbehorende processen zal handhaven."
+                                  ]
+        (English,_,_)     -> Para [ Str "There are roles assigned to rules outside the bounds of the process. "
+                                  , Str "The following table shows which rules that are defined in a pattern are linked to a role within a process."
+                                  , Str "This has as consequence that these rule(s) will be maintained in the corresponding process(es)."
+                                  ]
+     | (not.null.vprocesses) fSpec && (not.null) [rra | prc<-procs, rra<-maintains prc]
+     ]        ++          
+-- the table containing the role-rule assignments
+     [ Table []
+       ([AlignLeft]++[AlignLeft | multProcs]++[AlignLeft,AlignLeft])
+       ([0.0]++[0.0 | multProcs]++[0.0,0.0])
+       ( case language flags of
+          Dutch   ->
+              [[Plain [Str "rol"]] ]++[[Plain [Str "in proces" ]] | multProcs]++[[Plain [Str "regel"]], [Plain [Str "uit"  ]] ]
+          English ->
+              [[Plain [Str "role"]]]++[[Plain [Str "in process"]] | multProcs]++[[Plain [Str "rule" ]], [Plain [Str "from" ]] ]
+       )
+       [ [[Plain [Str rol]]]++[[Plain [Str (name p)]] | multProcs]++[[Plain [Str (name rul)]], [Plain [Str (r_env rul)]]]
+       | (p,rol,rul)<-prs
+       ] 
+     | length prs>1]
+     where prs = [(p,rol,rul) | p<-procs, (rol,rul)<-maintains p, name rul `notElem` map name (udefrules p) ]
+           multProcs = length procs>1
+           procs = [fpProc fp | fp<-vprocesses fSpec
+                            , null (themes fSpec) || name fp `elem` themes fSpec]  -- restrict if this is partial documentation.
+
+--  populationReport :: [Block]
+--  populationReport
+--   = [ Para (case (language flags, ps, declarations fSpec) of
+--        (Dutch,  [], [] ) -> [ Str "Dit script is leeg. " ]
+--        (English,[], [] ) -> [ Str "This script is empty. " ]
+--        (Dutch,  [],  _ ) -> [ Str "Geen relatie bevat enige populatie. " ]
+--        (English,[],  _ ) -> [ Str "No relation contains any population. " ]
+--        (Dutch,  [p],[_]) -> [ Str "Relatie ", Math InlineMath ((showMath.popdcl) p), Str " heeft een populatie van ", Str (count flags (length (popps p)) "paar"), Str ". " ]  -- Every d is typeable, so showMathDamb may be used.
+--        (English,[p],[_]) -> [ Str "Relation ", Math InlineMath ((showMath.popdcl) p), Str " has ", Str (count flags (length (popps p)) "pair"), Str " in its population. " ]
+--        (Dutch,  [p], _ ) -> [ Str "Alleen relatie ", Math InlineMath ((showMath.popdcl) p), Str " heeft een populatie. Deze bevat ", Str (count flags (length (popps p)) "paar"), Str ". " ]
+--        (English,[p], _ ) -> [ Str "Only relation ", Math InlineMath ((showMath.popdcl) p), Str " is populated. It contains ", Str (count flags (length (popps p)) "pair"), Str ". " ]
+--        (Dutch,   _ , _ ) -> [ Str "De onderstaande tabel geeft de populatie van de verschillende relaties weer. " ]
+--        (English, _ , _ ) -> [ Str "The following table represents the population of various relations. " ])
+--     ] ++
+--     [ Table []
+--        [AlignLeft,AlignRight]
+--        [0.0,0.0]
+--        (case language flags of
+--          Dutch   -> [[Plain [Str "Concept"]], [Plain [Str "Populatie"]  ]]
+--          English -> [[Plain [Str "Concept"]], [Plain [Str "Population"] ]]
+--        )
+--        [ [[Plain [Str (name c)]], [Plain [(Str . show . length . atomsOf) c]]]
+--        | c<-cs
+--        ]
+--     | length cs>=1 ] ++
+--     [ Table []
+--        [AlignLeft,AlignRight]
+--        [0.0,0.0]
+--        (case language flags of
+--          Dutch   -> [[Plain [Str "Relatie"]],  [Plain [Str "Populatie"]  ]]
+--          English -> [[Plain [Str "Relation"]], [Plain [Str "Population"] ]]
+--        )
+--        [ [[Plain [Math InlineMath ((showMath .popdcl) p)]], [Plain [(Str . show . length . popps) p]]]  -- Every d is typeable, so showMathDamb may be used.
+--        | p<-ps
+--        ]
+--     | length ps>1 ]
+--     where
+--      ps  = [p | p<-initialPops fSpec
+--               , null (themes fSpec) || (decpat.popdcl) p `elem` themes fSpec  -- restrict if the documentation is partial.
+--               , (not.null.popps) p]
+--      cs  = [c | c@C{}<-ccs, (not.null.atomsOf) c]
+--      ccs = concs [ d | d<-declarations fSpec, null (themes fSpec)||decpat d `elem` themes fSpec]  -- restrict if the documentation is partial.
+
+  wipReport :: [Block]
+  wipReport
+   = [ Para (case (language flags, 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 flags (length ps) "taak"++" zien.") ]
+              (English,[(r,ps)],_) -> [ Str "Rule ", quoterule r, Str (" shows "++count flags (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 language flags 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 language flags of
+                  Dutch   -> Str "Regel"
+                  English -> Str "Rule"):
+                [Space,quoterule r,Space]++
+                if xrefSupported flags then [ Str "(", RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ symReqRef r, Str ") "] else []++
+                (case language flags of
+                  Dutch   -> [ Str "luidt: " ]
+                  English -> [ Str "says: "  ]
+                )  
+              )]  ++meaning2Blocks (language flags) r++
+       [Plain ( case language flags of
+                  Dutch  ->
+                     [ Str "Deze regel bevat nog werk (voor "]++
+                     commaNLPandoc (Str "of") (nub [Str rol | (rol, rul)<-fRoleRuls fSpec, r==rul])++[Str ")"]++
+                     (if length ps == 1 then [Str ", te weten "]++oneviol r ps++[Str ". "] else
+                      [ Str (". De volgende tabel laat de "++(if length ps>10 then "eerste tien " else "")++"items zien die aandacht vragen.")]
+                     )
+                  English ->
+                     [ Str "This rule contains work"]++
+                     commaEngPandoc (Str "or") (nub [Str rol | (rol, rul)<-fRoleRuls fSpec, r==rul])++[Str ")"]++
+                     if length ps == 1 then [Str " by "]++oneviol r ps++[Str ". "] else
+                      [ Str ("The following table shows the "++(if length ps>10 then "first ten " else "")++"items that require attention.")]
+                     
+              ) ]++
+       [ violtable r ps | length ps>1]
+     | (r,ps)<-concat popwork ]
+     where
+--      text r
+--       = if null expls
+--         then explains2Blocks (autoMeaning (language flags) r) 
+--         else expls 
+--         where expls = [Plain (block++[Space]) | Means l econt<-rrxpl r, l==Just (language flags) || l==Nothing, Para block<-econt]
+      quoterule r
+       = if name r==""
+         then case language flags of
+               English -> Str ("on "++show (origin r))
+               Dutch   -> Str ("op "++show (origin r))
+         else Quoted SingleQuote [Str (name r)]
+      oneviol r [(a,b)]
+       = if source r==target r && a==b
+         then [Quoted  SingleQuote [Str (name (source r)),Space,Str a]]
+         else [Str "(",Str (name (source r)),Space,Str a,Str ", ",Str (name (target r)),Space,Str b,Str ")"]
+      oneviol _ _ = fatal 810 "oneviol must have a singleton list as argument."
+      popwork :: [[(Rule,[(String, String)])]];
+      popwork = eqCl (locnm.origin.fst) [(r,ps) | (r,ps) <- allViolations fSpec, isSignal r, partofThemes r]
+  partofThemes r = 
+        or [ null (themes fSpec) 
+           , r `elem` concat [udefrules pat | pat<-patterns fSpec, name pat `elem` themes fSpec]
+           , r `elem` concat [udefrules (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec]
+           ]
+
+  violationReport :: Blocks    
+  violationReport
+   = let (processViolations,invariantViolations) = partition (isSignal.fst) (allViolations fSpec)
+         showViolatedRule :: (Rule,Pairs) -> Blocks
+         showViolatedRule (r,ps) 
+             = let capt = case (language flags,isSignal r) of
+                               (Dutch  , False) -> text "Overtredingen van regel "<>  text (name r)
+                               (English, False) -> text "Violations of rule "<>  text (name r)
+                               (Dutch  , True ) -> text "Openstaande taken voor " <> text (commaNL  "of" (nub [rol | (rol, rul)<-fRoleRuls fSpec, r==rul]))
+                               (English, True ) -> text "Tasks yet to be performed by "  <> text (commaEng "or" (nub [rol | (rol, rul)<-fRoleRuls fSpec, r==rul]))
+                         
+                   showRow :: Paire -> [Blocks]
+                   showRow p = [(para.text.fst) p,(para.text.snd) p]
+               in para ( case language flags of
+                            Dutch   -> text "Regel "
+                            English -> text "Rule "
+                         <>  text (name r)
+                       )
+               <> para (text (case (language flags,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 (language flags, invariantViolations, processViolations) of
+                (Dutch  ,[] , [] ) -> text "De populatie in dit script overtreedt geen regels. "
+                (English,[] , [] ) -> text "The population in this script violates no rule. "
+                (Dutch  ,iVs, pVs) 
+                   -> text ("De populatie in dit script overtreedt "
+                             ++show(length iVs)++" invariant"++(if length iVs == 1 then "" else "en")++" en "
+                             ++show(length pVs)++" procesregel"++if length pVs == 1 then "" else "s"++"."
+                           )
+                (English,iVs, pVs) 
+                   -> text ("The population in this script violates "
+                             ++show(length iVs)++" invariant"++(if length iVs == 1 then "" else "s")++" and "
+                             ++show(length pVs)++" process rule"++if length pVs == 1 then "" else "s"++"."
+                           )
+              )
+        )
+     <> bulletList  [showViolatedRule vs | vs<- invariantViolations]
+     <> bulletList  [showViolatedRule vs | vs<- processViolations]
+        
+             
+---- the table containing the rule violation counts
+--     [ Table []
+--       [AlignLeft,AlignRight,AlignRight]
+--       [0.0,0.0,0.0]
+--       ( case language flags of
+--          Dutch   ->
+--             [[Plain [Str "regel"]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length popviol>1]++[Str "regel#"]], [Plain [Str "#overtredingen"] ]]
+--          English ->
+--             [[Plain [Str "rule" ]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length popviol>1]++[Str "line#"]], [Plain [Str "#violations"] ]]
+--       )
+--       [ [[Plain [Str (name r)]], [Plain [(Str . locln . origin) r]], [Plain [(Str . show . length) ps]]]
+--       | (r,ps)<-cl, length ps>0
+--       ]
+--     | (length.concat) popviol>1, cl<-popviol, not (null cl) ]        ++          
+---- the table containing the multiplicity counts
+--     [ Table []
+--       [AlignLeft,AlignRight,AlignRight]
+--       [0.0,0.0,0.0]
+--       ( case language flags of
+--           Dutch   ->
+--              [[Plain [Str "regel"]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length multviol>1]++[Str "regel#"]], [Plain [Str "#overtredingen"] ]]
+--           English ->
+--              [[Plain [Str "rule" ]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length multviol>1]++[Str "line#"]], [Plain [Str "#violations"] ]]
+--       )
+--       [ [[Plain [Str (name r)]], [Plain [(Str . locln . origin) r]], [Plain [(Str . show . length) ps]]]
+--       | (r,ps)<-cl, length ps>0
+--       ]
+--     | (length.concat) multviol>1, cl<-multviol, not (null cl) ]        ++          
+-- the tables containing the actual violations of user defined rules
+--     concat
+--     [ [ Para ( (case language flags of
+--                   Dutch   -> Str "Regel"
+--                   English -> Str "Rule"):
+--                [Space,quoterule r,Space]++
+--                if fspecFormat flags==FLatex then [ Str "(", RawInline (Text.Pandoc.Builder.Format "latex") $ symReqRef r, Str ") "] else []++
+--                (case language flags of
+--                    Dutch   -> [ Str "luidt: " ]
+--                    English -> [ Str "says: "])
+--              )]  ++meaning2Blocks (language flags) r++
+--       [Plain ( case language flags of
+--                  Dutch   ->
+--                     Str "Deze regel wordt overtreden":
+--                     (if length ps == 1 then [Str " door "]++oneviol r ps++[Str ". "] else
+--                      [ Str (". De volgende tabel laat de "++if length ps>10 then "eerste tien " else ""++"overtredingen zien.")]
+--                     )
+--                  English ->
+--                     Str "This rule is violated":
+--                     (if length ps == 1 then [Str " by "]++oneviol r ps++[Str ". "] else
+--                      [ Str ("The following table shows the "++if length ps>10 then "first ten " else ""++"violations.")]
+--                     )
+--              )]++
+--       [ violtable r ps | length ps>1]
+--     | (r,ps)<-popviols, length popviols>1 ]++
+---- the tables containing the actual violations of multiplicity rules
+--     [ BulletList
+--       [ textMult r++
+--         [Plain ( case language flags of
+--                   Dutch   ->
+--                     if length ps == 1 then [Str "Deze regel wordt overtreden door "]++oneviol r ps++[Str ". "] else
+--                      [ Str ("De volgende tabel laat de "++(if length ps>10 then "eerste tien overtredingen zien." else count flags (length ps) ((unCap.name.source)r)++" zien die deze regel overtreden."))]
+--                     
+--                   English ->
+--                     if length ps == 1 then [Str "This rule is violated by "]++oneviol r ps++[Str ". "] else
+--                      [ Str ("The following table shows the "++(if length ps>10 then "first ten violations." else count flags (length ps) ((unCap.name.source)r)++" that violate this rule."))]
+--                     
+--                )]++
+--         [ violtable r ps | length ps>1]
+--       | (r,ps)<-multviols, length multviols>1 ]
+--     | not (null multviols) ]
+--     where
+--     textMult r
+--       = concat [    [Plain [Str "De relatie ",Space]]
+--                  ++ amPandoc mrkup
+--                  ++ [Plain [Str ".",Space]]
+--                  
+--                 | mrkup <- (ameaMrk . rrmean) r, amLang mrkup==language flags]
+--     quoterule r = if name r==""
+--                   then Str ("on "++show (origin r))
+--                   else Quoted SingleQuote [Str (name r)]
+--     oneviol r [(a,b)]
+--      = if source r==target r && a==b
+--        then [Quoted  SingleQuote [Str (name (source r)),Space,Str a]]
+--        else [Str "(",Str (name (source r)),Space,Str a,Str ", ",Str (name (target r)),Space,Str b,Str ")"]
+--     oneviol _ _ = fatal 810 "oneviol must have a singleton list as argument."
+--     popviols  = [(r,ps) | (r,ps) <- allViolations fSpec, partofThemes r,      r_usr r == UserDefined ]
+--     multviols = [(r,ps) | (r,ps) <- allViolations fSpec, partofThemes r, not (r_usr r == UserDefined)]
+     
+
+--     popviols = [(r,ps) | r<-invs++identityRs
+--                        , let ps=ruleviolations r, not (null ps)]
+--     multviols = [(r,ps) | r<-mults
+--                         , let ps=ruleviolations r, not (null ps)]
+--     popviol :: [[(Rule,[(String, String)])]]
+--     popviol  = eqCl (locnm.origin.fst) [(r,ps) | r<-invs, let ps=ruleviolations r, not (null ps)]
+--     multviol :: [[(Rule,[(String, String)])]]
+--     multviol  = eqCl (locnm.origin.fst) [(r,ps) | r<-mults, let ps=ruleviolations r, not (null ps)]
+--     invs  = if null (themes fSpec)
+--             then invariants fSpec
+--             else concat [invariants pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++
+--                  concat [invariants (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec]
+--     mults = if null (themes fSpec)
+--             then multrules fSpec
+--             else concat [multrules pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++
+--                  concat [multrules (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec]
+--     identityRs = if null (themes fSpec)
+--                  then identityRules fSpec
+--                  else concat [identityRules pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++
+--                       concat [identityRules (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec]
+
+  violtable 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 a]]]
+             | (a,_)<-take 10 ps
+             ]
+        else Table []
+             [AlignLeft,AlignLeft]
+             [0.0,0.0]
+             [[Plain [(Str . name . source) r]], [Plain [(Str . name . target) r] ]]
+             [ [[Plain [Str a]], [Plain [Str b]]]
+             | (a,b)<-take 10 ps
+             ]
+        
+
+ src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterECArules.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterECArules
+where
+import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
+import DatabaseDesign.Ampersand.ADL1
+import DatabaseDesign.Ampersand.Output.PandocAux
+
+chpECArules :: Fspc -> Options ->  Blocks
+chpECArules fSpec flags
+ =   chptHeader flags EcaRules
+  <> ecaIntro
+  <> ifcECA
+ where
+  ecaIntro :: Blocks
+  ecaIntro
+   = fromList
+     [ Plain $ case language flags of
+       Dutch   -> [Str "Dit hoofdstuk bevat de ECA regels." ]
+       English -> [Str "This chapter lists the ECA rules." ]
+     ]
+  ifcECA :: Blocks
+  ifcECA
+   = fromList $
+     case language flags of
+      Dutch   -> Para [ Str "ECA rules:",LineBreak, Str "   ",Str "tijdelijk ongedocumenteerd" ] : 
+                 [ BlockQuote (toList (codeBlock
+                      ( showECA fSpec "\n     " eca
+-- Dit inschakelen          ++[LineBreak, Str "------ Derivation ----->"]
+--  voor het bewijs         ++(showProof (showECA fSpec [LineBreak, Str ">     ") (proofPA (ecaAction (eca arg)))
+--                          ++[LineBreak, Str "<------End Derivation --"]
+                      ) ) )
+                 | eca<-vEcas fSpec, not (isNop (ecaAction eca))]
+      English -> Para [ Str "ECA rules:",LineBreak, Str "   ",Str "temporarily not documented" ] :
+                 [ BlockQuote (toList (codeBlock
+                    ( showECA fSpec "\n" eca )))
+                 | eca<-vEcas fSpec, not (isNop (ecaAction eca))]
+
+ src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterGlossary.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterGlossary
+  (chpGlossary)
+where
+import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
+import DatabaseDesign.Ampersand.ADL1
+import DatabaseDesign.Ampersand.Classes
+
+
+chpGlossary :: Int -> Fspc -> Options ->  Blocks
+chpGlossary _ fSpec flags
+ = fromList $
+   if fspecFormat flags==FLatex
+   then [ Para [RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "\\printglossaries"] ]
+   else [ Table [] [AlignLeft,AlignLeft,AlignLeft] [0.0,0.0,0.0]
+          ( case language flags of
+               Dutch   ->
+                 [ [Plain [Str "term"]] , [Plain [Str "definitie"]] , [Plain [Str "bron"]]]
+               English ->
+                 [ [Plain [Str "term"]] , [Plain [Str "definition"]], [Plain [Str "source"]]]
+          )
+          [ [ [Plain [(Str . name)  c]], [Plain [(Str . cddef) cd]], [Plain [(Str . cdref) cd]]]
+          | c<-concs fSpec, cd<-cptdf c
+          ]]
+ src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterInterfaces.hs view
@@ -0,0 +1,251 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterInterfaces
+  ( chpInterfacesPics
+  , chpInterfacesBlocks
+  )
+where
+import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
+import DatabaseDesign.Ampersand.ADL1
+import Data.List
+import DatabaseDesign.Ampersand.Fspec.Fspec
+import DatabaseDesign.Ampersand.Fspec.Switchboard      (switchboardAct)
+import DatabaseDesign.Ampersand.Output.PandocAux
+
+chpInterfacesPics :: Fspc -> Options -> [Picture]
+chpInterfacesPics fSpec flags =
+   concat [picKnowledgeGraph flags fSpec act : [picSwitchboard flags fSpec act | graphic flags] | act <- fActivities fSpec ]
+chpInterfacesBlocks :: Int -> Fspc -> Options -> Blocks
+chpInterfacesBlocks lev fSpec flags =
+   foldr (<>) mempty (map interfaceChap (fActivities fSpec))  
+ where 
+   interfaceChap :: Activity -> Blocks
+   interfaceChap act
+   -- TODO: This should be one chapter for all interfaces.
+    = ( fromList $ 
+         header act ++ ifcIntro act
+         ++ (if genGraphics flags then txtKnowledgeGraph act else [])
+         -- ifcFieldTables
+         ++ (if graphic flags then txtSwitchboard act else [])
+ --     , picKnowledgeGraph : [picSwitchboard | graphic]
+      )
+   header :: Activity ->[Block]
+   header act = toList (labeledThing flags lev ("chpIfc"++name act) (name act))
+   ifcIntro :: Activity -> [Block]
+   ifcIntro act
+    = purposes2Blocks flags purps
+      ++ifcAutoRules act++
+      (if genEcaDoc flags then ifcEcaRules act else [])
+      where purps = purposesDefinedIn fSpec (language flags) fSpec
+
+{-
+  ifcInsDelConcepts :: [Block]
+  ifcInsDelConcepts
+   = let ics = fsv_creating act>-fsv_deleting act
+         dcs = fsv_deleting act>-fsv_creating act
+         ucs = fsv_deleting act `isc` fsv_creating act
+     in case language flags of
+      Dutch -> [Plain [Space]]++
+          if null ics && null dcs && null ucs then [Plain $ [Str "Deze interface maakt of verwijdert geen objecten langs geautomatiseerde weg."]] else
+          if null ics && null dcs             then [Plain $ [Str "Om regels te handhaven, mogen instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " door deze interface geautomatiseerd worden aangemaakt en verwijderd."]] else
+          if null ics       &&       null ucs then [Plain $ [Str "Om regels te handhaven, mag deze interface instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " geautomatiseerd verwijderen."]] else
+          if             null dcs && null ucs then [Plain $ [Str "Om regels te handhaven, mogen instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " geautomatiseerd worden aangemaakt door deze interface."]] else
+          if                         null ucs then [Plain $ [Str "Instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " mogen worden toegevoegd en instanties van "]++f dcs++[Str " mogen worden verwijderd door deze interface. Dat gebeurt geautomatiseerd en uitsluitend waar nodig om regels te handhaven."]] else
+          if             null dcs             then [Plain $ [Str "Deze interface mag instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ics)++[Str " creeren, terwijl instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " ook verwijderd mogen worden. Alleen waar nodig mag dit plaatsvinden om regels te handhaven."]] else
+          if null ics                         then [Plain $ [Str "Deze interface mag instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " wijzigen, maar instanties van "]++commaNLPandoc (Str "en") (map (Str . name) dcs)++[Str " mogen alleen worden verwijderd. Dat mag slechts dan gebeuren wanneer dat nodig is voor het handhaven van regels."]] else
+          [Plain $ [Str "Deze interface maakt nieuwe instanties van concept"]++f ics++[Str ". Hij mag instanties van concept"]++f dcs++[Str " verwijderen, terwijl instanties van "]++commaNLPandoc (Str "en") (map (Str . name) ucs)++[Str " zowel gemaakt als vernietigd mogen worden."]]
+          where f [x] = [Space, Str (name x), Space]
+                f xs  = [Str "en "]++commaNLPandoc (Str "en") (map (Str . name) xs)
+      English -> [Plain [Space]]++
+          if null ics && null dcs && null ucs then [Plain $ [Str "In this interface, no objects are made or removed automatically."]] else
+          if null ics && null dcs             then [Plain $ [Str "In order to maintain rules, instances of "]++f ucs++[Str " may be created or deleted by this interface automatically."]] else
+          if null ics       &&       null ucs then [Plain $ [Str "In order to maintain rules, instances of "]++f dcs++[Str " may be deleted automatically by this interface."]] else
+          if             null dcs && null ucs then [Plain $ [Str "In order to maintain rules, instances of "]++f ics++[Str " may be automatically inserted by this interface."]] else
+          if                         null ucs then [Plain $ [Str "Concept"]++f ics++[Str " may be inserted, and concept"]++f dcs++[Str " may be deleted by this interface. This happens only if necessary for maintaining rules."]] else
+          if             null dcs             then [Plain $ [Str "By this interface, concept"]++f ucs++[Str " may be changed, but"]++f ics++[Str " may be created but not deleted. This happens only if necessary for maintaining rules."]] else
+          if null ics                         then [Plain $ [Str "By this interface, concept"]++f ucs++[Str " may be changed, but"]++f dcs++[Str " may only be deleted. This happens only if necessary for maintaining rules."]] else
+          [Plain $ [Str "This interface can create new instances of concept"]++f ics++[Str ". It may delete instances of concept"]++f dcs++[Str ", and instances of concept"]++f ucs++[Str " may be either created and removed. Such actions will take place only in order to maintain rules."]]
+          where f [x] = [Space, Str (name x)]
+                f xs  = [Str "s "]++commaEngPandoc (Str "and") (map (Str . name) xs)
+-}
+
+   ifcAutoRules :: Activity -> [Block]
+   ifcAutoRules act
+    = case language flags of
+       Dutch ->   [Plain ([Str "Activiteit",Space, Quoted SingleQuote [(Str . name . actRule) act], Space,Str "moet door een gebruiker met rol "]++commaNLPandoc (Str "of") rols++[Str" worden uitgevoerd."] ++
+                          case length auts of
+                           0 -> []
+                           1 -> [Space,Str "Daarbij wordt regel",Space]++auts++[Space,Str "gehandhaafd zonder interventie van de gebruiker."]
+                           _ -> [Space,Str "Daarbij worden regels",Space]++commaNLPandoc (Str "en") auts++[Space,Str "gehandhaafd zonder interventie van de gebruiker."]
+                  )]
+       English -> [Plain ([Str "Activity",Space, Quoted SingleQuote [(Str . name . actRule) act], Space,Str "must be performed by a user with role "]++commaEngPandoc (Str "or") rols++[Str"."] ++
+                          case length auts of
+                           0 -> []
+                           1 -> [Space,Str "During that activity, rule",Space]++auts++[Space,Str "will be maintained without intervention of a user."]
+                           _ -> [Space,Str "During that activity, rules",Space]++commaEngPandoc (Str "and") auts++[Space,Str "will be maintained without intervention of a user."]
+                  )]
+      where
+         auts = nub [ Quoted  SingleQuote [Str (name r)] | q<-actQuads act, let r=(cl_rule.qClauses) q, r_usr r == UserDefined]
+         rols = nub [Str r | (r,rul)<-fRoleRuls fSpec, rul==actRule act] 
+
+   ifcEcaRules :: Activity -> [Block]
+   ifcEcaRules act
+    = ( case (language flags, actEcas act) of
+         (Dutch,[])   -> [Plain [Str "Alle veranderingen die een gebruiker uitvoert zijn handmatig. Er is geen geautomatiseerde functionaliteit in deze activiteit."]]
+         (English,[]) -> [Plain [Str "All changes a user makes are done by hand. There is no automated functionality in this activity."]]
+         (Dutch,_)    -> [Plain [Str "De volgende tabel laat zien welke edit-acties welke functie aanroepen."]]
+         (English,_)  -> [Plain [Str "The following table shows which edit actions invoke which function."]]
+      )++
+      if length (actEcas act)<1 then [] else
+      [ Table [] [AlignLeft,AlignLeft,AlignLeft] [0.0,0.0,0.0]
+        ( case language flags of
+           Dutch   ->
+               [[Plain [Str "actie"]]
+               ,[Plain [Str "relatie"]]
+               ,[Plain [Str "regel"]]]
+           English   ->
+               [[Plain [Str "action"]]
+               ,[Plain [Str "relation"]]
+               ,[Plain [Str "rule"]]] )
+        [ [ [Plain [ (Str . show . eSrt.ecaTriggr) eca]]
+          , [Plain [ (Str . show . eDcl.ecaTriggr) eca]]
+          , [Plain (shwEca eca)]
+          ] 
+        | eca<-actEcas act  -- tail haalt het eerste veld, zijnde I[c], eruit omdat die niet in deze tabel thuishoort.
+        ]]
+     where
+      shwEca :: ECArule -> [Inline]
+      shwEca eca
+       | isBlk (ecaAction eca)
+            = Str "error: rule ":
+              commaEngPandoc (Str "and")
+                       [ Quoted  SingleQuote [Str (let nrRules = length rs
+                                                       s  | nrRules == 0  = ""
+                                                          | nrRules == 1  = name (head rs)
+                                                          | otherwise     = name (head rs)++" (and "++show(nrRules - 1)++" other rules)."
+                                                   in s
+                                                  )]
+                       | (_,rs)<-paMotiv (ecaAction eca)
+                       ] 
+       | isNop (ecaAction eca)
+            = [ Str "no op"]
+       | otherwise = [ Str "ECA rule ", Str ((show . ecaNum ) eca) ]
+{-
+  ifcFieldTables
+   = if null (fsv_fields act) then [] else
+     if length (fsv_fields act)==1
+     then [ Para  $ [ case language flags of
+                       Dutch   -> Str "In deze interface is het volgende veld zichtbaar: "
+                       English -> Str "This interface has one field: "
+                    ]
+          , head [b | BulletList [bs]<-[flds], b<-bs]
+          ]
+     else [ Para  $ [ case language flags of
+                       Dutch   -> Str "In deze interface zijn de volgende velden zichtbaar. "
+                       English -> Str "This interface has the following fields. "
+                    ]
+          , flds
+          ]
+     where flds :: Block
+           flds = BulletList [recur ((objctx.ifcObj.fsv_ifcdef) act) f | f<-fsv_fields act]
+            where recur :: Expression -> Field -> [Block]
+                  recur e f | null (fld_sub f) = fld e f
+                            | otherwise        = fld e f ++
+                                                 [ BulletList [recur (ECps [e,fld_expr f']) f' | f'<-fld_sub f] ]
+           fld e f = [ Para [ Str (dealWithUnderscores (fld_name f)++if null cols then "" else "("++intercalate ", " cols++")") ]
+                     , Para [ Str "display on start: ", Math InlineMath $ showMath (conjNF e) ]
+                     ] 
+            where cols = ["lijst"         | fld_list    f]++
+                         ["verplicht"     | fld_must    f]++
+                         ["nieuw"         | fld_insAble f]++
+                         ["verwijderbaar" | fld_delAble f]
+                     
+           dealWithUnderscores :: String -> String
+           dealWithUnderscores x = 
+                  case x of 
+                    []     -> []
+                    '_':cs -> "\\_" ++ dealWithUnderscores cs
+                    c:cs   -> c : dealWithUnderscores cs
+-}
+
+   txtKnowledgeGraph :: Activity -> [Block]
+   txtKnowledgeGraph act
+    = (case language flags of                                     -- announce the knowledge graph
+           Dutch   -> [Para [ Str "Figuur ", xrefReference (picKnowledgeGraph flags fSpec act) 
+                            , Str " geeft de kennisgraaf weer voor deze interface."]]
+           English -> [Para [ Str "Figure ", xrefReference (picKnowledgeGraph flags fSpec act)
+                            , Str " shows the knowledge graph of this interface."]]
+      )
+      ++ [Plain (xrefFigure1 (picKnowledgeGraph flags fSpec act))]    -- draw the knowledge graph
+
+   txtSwitchboard :: Activity ->[Block]
+   txtSwitchboard act
+    = (if name act==name (head (fActivities fSpec)) then switchboardIntro else [])++
+     (case language flags of                                     -- announce the switchboard diagram
+           Dutch   -> [Para [ Str "Figuur ", xrefReference (picSwitchboard flags fSpec act)
+                            , Str " geeft het schakelpaneel (switchboard diagram) weer voor deze interface."]]
+           English -> [Para [ Str "Figure ", xrefReference (picSwitchboard flags fSpec act)
+                            , Str " shows the switchboard diagram of this interface."]]
+     )
+     ++ [Plain (xrefFigure1 (picSwitchboard flags fSpec act))]        -- draw the switchboard
+
+   switchboardIntro :: [Block]
+   switchboardIntro
+    = if not (graphic flags) then [] else
+     [ Para $ case language flags of                             -- tells us for who this interface exists
+        Dutch   -> [ Str "Iedere sectie in dit hoofdstuk beschrijft één activiteit. "
+                   , Str "Tijdens het uitvoeren van een activiteit zal een gebruiker populatie invoegen of verwijderen in verschillende relaties. "
+                   , Str "Hierdoor kunnen invarianten potentieel worden overtreden. "
+                   , Str "(Een invariant is een bedrijfsregel die op ieder moment waar moet blijven.) "
+                   , Str "De software die nodig is om invarianten waar te maken wordt automatisch gegenereerd. "
+                   , Str "De structuur van deze software wordt geïllustreerd door een zogenaamd schakelpaneel (switchboard-diagram), "
+                   , Str "waarvan u de eerste in figuur X aantreft. "
+                   , Str "Elk switchboard diagram bestaat uit drie kolommen: "
+                   , Str "Invariante regels staan in het midden en relaties staan aan de (linker en rechter) zijkanten. "
+                   , Str "Een pijl ter linkerzijde wijst van een relatie die ge-edit wordt naar een regel die daardoor mogelijk overtreden wordt. "
+                   , Str "Elke pijl ter rechterzijde van een regel representeert een edit-actie die nodig is om het waar-zijn ervan te herstellen. "
+                   , Str "Deze pijl wijst naar de relatie waarin deze herstel-actie moet worden uitgevoerd. "
+                   , Str "Een pijl gelabeled met '+' duidt op een insert event; een pijl met '-' op  "
+                   , Str "Hierdoor onstaat een accuraat beeld op welke manier de activiteit alle invarianten handhaaft. "
+                   ]
+        English -> [ Str "Every section in this chapter describes one activity. "
+                   , Str "While performing an activity, users will insert or delete population in various relations. "
+                   , Str "This may potentially violate invariants. "
+                   , Str "(An invariant is a business rule rules that must remain true at all times.) "
+                   , Str "The software to maintain the truth of invariant rules is generated automatically. "
+                   , Str "The structure of that software is illustrated by a so called switchboard diagram, "
+                   , Str "the first of which you will find in figure X. "
+                   , Str "Each switchboard diagram consists of three columns: "
+                   , Str "Invariant rules are drawn in the middle, and relations occur on the (right and left hand) sides. "
+                   , Str "An arrow on the left hand side points from a relation that may be edited to a rule that may be violated as a consequence thereof. "
+                   , Str "Each arrow on the right hand side of a rule represents an edit action that is required to restore its truth. "
+                   , Str "It points to the relation that is edited for that purpose. "
+                   , Str "If that arrow is labeled '+', it involves an insert event; if labeled '-' it refers to a delete event. "
+                   , Str "This yields an accurate perspective on the way in which invariants are maintained. "
+                   ]
+     ]
+
+picKnowledgeGraph :: Options -> Fspc -> Activity ->Picture
+picKnowledgeGraph flags fSpec act
+    = (makePicture flags fSpec Plain_CG act)  -- the Picture that represents this interface's knowledge graph
+        {caption = case language flags of
+                    Dutch   ->"Taaldiagram van "++name act
+                    English ->"Language diagram of "++name act}
+--     where
+--      knGph = conceptualGraph fSpec flags Plain_CG act         -- the DotGraph String that represents this interface's knowledge graph
+--      kn    = printDotGraph knGph                     -- the String that represents this interface's knowledge graph
+
+picSwitchboard :: Options -> Fspc -> Activity -> Picture
+picSwitchboard flags fSpec act
+    = (makePicture flags fSpec Plain_CG (switchboardAct fSpec act)) -- the Picture that represents this interface's knowledge graph
+        {caption = case language flags of
+                    Dutch   ->"Schakelpaneel van "++name act
+                    English ->"Switchboard of "++name act}
+--     where
+--      sbGph = switchboardAct fSpec act                              -- the DotGraph String that represents this interface's knowledge graph
+--      sb    = printDotGraph sbGph                                -- the String that represents this interface's knowledge graph
+
+
+graphic :: Options -> Bool
+graphic flags = genGraphics flags && theme flags /= StudentTheme
+
+ src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterIntroduction.hs view
@@ -0,0 +1,150 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterIntroduction
+where
+import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
+import Data.Time.Format
+
+chpIntroduction :: Fspc -> Options -> Blocks
+chpIntroduction fSpec flags =
+      chptHeader flags Intro
+   <> fromList purposesOfContext  -- the motivation(s) of this context 
+   <> readingGuide                -- tells what can be expected in this document.
+  where 
+    readingGuide 
+      = case (language flags) of
+          Dutch
+            -> para ( text "Dit document"
+                   <> (note.para.text) ("Dit document is gegenereerd op "++date++" om "++time++", dmv. "++ampersandVersionStr++".")
+                   <> text " definieert de functionaliteit van een informatiesysteem genaamd "
+                   <> (singleQuoted.text.name) fSpec
+                   <> text ". "
+                   <> text "Het definieert de database en de business-services van " <> (text.name) fSpec <> text " door middel van bedrijfsregels"
+                   <> (note.para.text) "Het ontwerpen met bedrijfsregels is een kenmerk van de Ampersand aanpak, die gebruikt is bij het samenstellen van dit document. "
+                   <> text ". "
+                   <> (if SharedLang `elem` chaptersInDoc flags
+                       then ( if canXRefer flags 
+                              then text "Deze afspraken staan opgesomd in hoofdstuk "
+                                <> xRefReference flags SharedLang
+                              else text "Deze afspraken staan opgesomd in het hoofdstuk genaamd "
+                                <> (doubleQuoted.chptTitle flags) SharedLang
+                            ) <> text ", geordend op thema. "
+                       else text "Deze afspraken zijn niet opgenomen in dit document."
+                      )
+                    )
+            <> if Diagnosis `elem` chaptersInDoc flags
+               then para ((if canXRefer flags 
+                           then text "De diagnose in hoofdstuk "
+                             <> xRefReference flags Diagnosis
+                           else text "De diagnose in het hoofdstuk genaamd"
+                             <> (doubleQuoted.chptTitle flags) Diagnosis
+                          ) <> text " is bedoeld voor de auteurs om gebreken uit hun Ampersand model op te sporen. "
+                         )
+               else mempty
+            <> if ConceptualAnalysis `elem` chaptersInDoc flags
+               then para ( ( if canXRefer flags 
+                             then text "De conceptuele analyse in hoofdstuk "
+                               <> xRefReference flags ConceptualAnalysis
+                             else text "De conceptuele analyse in het hoofdstuk genaamd"
+                               <> (doubleQuoted.chptTitle flags) ConceptualAnalysis
+                           ) <> text " is bedoeld voor requirements engineers en architecten om de gemaakte afspraken"
+                             <> text " te valideren en te formaliseren. "
+                             <> text "Tevens is het bedoeld voor testers om eenduidige testgevallen te kunnen bepalen. "
+                             <> text "De formalisatie in dit hoofdstuk maakt consistentie van de functionele specificatie bewijsbaar. "
+                             <> text "Ook garandeert het een eenduidige interpretatie van de afspraken."
+                         )
+               else mempty
+            <> if DataAnalysis `elem` chaptersInDoc flags
+               then para ( text "De hoofdstukken die dan volgen zijn bedoeld voor de bouwers van "
+                        <> (singleQuoted.text.name) fSpec
+                        <> text ". "
+                        <> ( if canXRefer flags 
+                             then text "De gegevensanalyse in hoofdstuk "
+                               <> xRefReference flags DataAnalysis
+                             else text "De gegevensanalyse in het hoofdstuk genaamd"
+                               <> (doubleQuoted.chptTitle flags) DataAnalysis
+                           )
+                        <> text " beschrijft de gegevensverzamelingen waarop "
+                        <> (singleQuoted.text.name) fSpec
+                        <> text " wordt gebouwd. "
+                        <> text "Elk volgend hoofdstuk definieert één business service. "
+                        <> text "Hierdoor kunnen bouwers zich concentreren op één service tegelijk. "
+                         )
+                 <> para ( text "Tezamen ondersteunen deze services alle geldende afspraken. "
+                        <> text "Door alle functionaliteit uitsluitend via deze services te ontsluiten waarborgt "
+                        <> (singleQuoted.text.name) fSpec
+                        <> text " compliance ten aanzien van alle gestelde afspraken. "
+                         )
+               else mempty
+
+
+          English
+            -> para ( text "This document"
+                   <> (note.para.text) ("This document was generated at "++date++" on "++time++", using "++ampersandVersionStr++".")
+                   <> text " defines the functionality of an information system called "
+                   <> (singleQuoted.text.name) fSpec
+                   <> text ". "
+                   <> text "It defines the database and the business services of " <> (text.name) fSpec <> text " by means of business rules"
+                   <> (note.para.text) "Rule based design characterizes the Ampersand approach, which has been used to produce this document. "
+                   <> text ". "
+                   <> (if SharedLang `elem` chaptersInDoc flags
+                       then ( if canXRefer flags 
+                              then text "Those rules are listed in chapter "
+                                <> xRefReference flags SharedLang
+                                <> text ", ordered by theme. "
+                              else text "Those rules are listed in the chapter named "
+                                <> (doubleQuoted.chptTitle flags) SharedLang
+                            ) <> text ", ordered by theme. " 
+                       else text "Those rules are not included in this document."
+                      )
+                    ) 
+             <> if Diagnosis `elem` chaptersInDoc flags
+               then para ((if canXRefer flags 
+                           then text "The diagnosis in chapter "
+                             <> xRefReference flags Diagnosis
+                           else text "The diagnosis in the chapter named "
+                             <> (doubleQuoted.chptTitle flags) Diagnosis
+                          ) <> text " is meant to help the authors identify shortcomings in their Ampersand script."
+                         )
+               else mempty
+            <> if ConceptualAnalysis `elem` chaptersInDoc flags
+               then para ( ( if canXRefer flags 
+                             then text "The conceptual analysis in chapter "
+                               <> xRefReference flags ConceptualAnalysis
+                             else text "The conceptual analysis in the chapter named "
+                               <> (doubleQuoted.chptTitle flags) ConceptualAnalysis
+                           ) <> text " is meant for requirements engineers and architects to validate and formalize the requirements. "
+                             <> text "It is also meant for testers to come up with correct test cases. "
+                             <> text "The formalization in this chapter makes consistency of the functional specification provable. "
+                             <> text "It also yields an unambiguous interpretation of all requirements."
+                         )
+               else mempty
+            <> if DataAnalysis `elem` chaptersInDoc flags
+               then para ( text "Chapters that follow have the builders of "
+                        <> (singleQuoted.text.name) fSpec
+                        <> text " as their intended audience. "
+                        <> ( if canXRefer flags 
+                             then text "The data analysis in chapter "
+                               <> xRefReference flags DataAnalysis
+                             else text "The data analysis in the chapter named "
+                               <> (doubleQuoted.chptTitle flags) DataAnalysis
+                           )
+                        <> text " describes the data sets upon which "
+                        <> (singleQuoted.text.name) fSpec
+                        <> text " is built. "
+                        <> text "Each subsequent chapter defines one business service. "
+                        <> text "This allows builders to focus on a single service at a time. "
+                         )
+                 <> para ( text "Together, these services fulfill all commitments. "
+                        <> text "By disclosing all functionality exclusively through these services, "
+                        <> (singleQuoted.text.name) fSpec
+                        <> text " ensures compliance to all rules aggreed upon."
+                         )
+               else mempty
+      
+    date = formatTime (lclForLang flags) "%-d-%-m-%Y" (genTime flags)
+    time = formatTime (lclForLang flags) "%H:%M:%S" (genTime flags)
+ 
+    purposesOfContext = concat [amPandoc (explMarkup p) | p<-purposesDefinedIn fSpec (language flags) fSpec]
+    
+
+ src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs view
@@ -0,0 +1,416 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterNatLangReqs where
+
+import Data.Char hiding (Space)
+import Data.List
+import Data.List.Split
+import GHC.Exts (sortWith)
+import Data.Maybe
+import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters hiding (sortWith)
+import DatabaseDesign.Ampersand.ADL1
+import DatabaseDesign.Ampersand.Classes
+import DatabaseDesign.Ampersand.Output.PandocAux
+import Text.Pandoc.Builder
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.ChapterNatLangReqs"
+
+{- TODO: This module needs to be rewritten from scratch. Instead of deciding on the fly what should be included, 
+         a datastructure needs to be added to the fSpec, which contains per theme the concepts, rules and relations
+         that need to be printed.  
+-}
+chpNatLangReqs :: Int -> Fspc -> Options ->  Blocks
+chpNatLangReqs lev fSpec flags = 
+   fromList (header ++ dpIntro ++ dpRequirements ++ if genLegalRefs flags then legalRefs else [])
+  where
+  header :: [Block]
+  header = toList (chptHeader flags SharedLang)
+  legalRefs :: [Block]
+  legalRefs = toList (labeledThing flags (lev+1) "LegalRefs" sectionTitle) ++
+              [  Plain [ RawInline (Text.Pandoc.Builder.Format "latex") $  unlines $
+                         [ "\\begin{longtable}{lp{10cm}}"
+                         , "\\hline "
+                         , "{\\bf "++lawHeader ++ "} & {\\bf " ++ articleHeader ++"} \\\\"
+                         , "\\hline"
+                         , "\\endhead\n" ] ++ 
+                         [ wet ++ " & " ++ art ++"\\\\\n"
+                         | (wet, art) <- allRefs 
+                         ] ++
+                         [ "\\end{longtable}" ]
+                       ]
+                         
+              ]
+         where getWet ref = reverse . takeWhile (/=' ') . reverse $ ref --  the law is the last word in the ref
+               getArtikelen ref = reverse . dropWhile (`elem` " ,") .dropWhile (/=' ') . reverse $ ref 
+               -- the article is everything but the law (and we also drop any trailing commas)
+               (sectionTitle, lawHeader, articleHeader, separator) = 
+                 case language flags of
+                   Dutch   -> ("Referentietabel", "Wet", "Artikel", "en")
+                   English -> ("Reference table", "Law", "Article", "and")
+               
+               sortedScannedRefs :: [(String, [Either String Int])]
+               sortedScannedRefs = sort . nub $
+                             [ (getWet ref, scanRef $ trimSpaces art) 
+                             | refStr <- filter (not . null) . map explRefId $ explanations fSpec 
+                             , ref <- splitOn ";" refStr
+                             , art <- splitOn (" "++separator++" ") $ getArtikelen ref
+                             ]
+                    where trimSpaces = let f = reverse . dropWhile (' '==)
+                                       in f . f
+                             
+               allRefs = map (\(w,a) -> (w, unscanRef a)) sortedScannedRefs
+               
+               -- group string in number and text sequences, so "Art 12" appears after "Art 2" when sorting (unlike in normal lexicographic string sort)              
+               scanRef :: String -> [Either String Int]
+               scanRef "" = []
+               scanRef str@(c:_) | isDigit c = scanRefInt str
+                                 | otherwise = scanRefTxt str
+               scanRefTxt "" = []
+               scanRefTxt str = let (txt, rest) = break isDigit str
+                                in  Left txt : scanRefInt rest
+
+               scanRefInt "" = []
+               scanRefInt str = let (digits, rest) = break (not . isDigit) str
+                                in  Right (read digits) : scanRefTxt rest
+
+               unscanRef :: [Either String Int] -> String
+               unscanRef scannedRef = concat $ map (either id show) scannedRef
+
+  dpIntro :: [Block]
+  dpIntro = 
+    case language flags of
+        Dutch   -> [ Para
+                     [ Str "Dit hoofdstuk beschrijft een natuurlijke taal, waarin functionele eisen ten behoeve van "
+                     , Quoted  SingleQuote [Str (name fSpec)]
+                     , Str " kunnen worden besproken en uitgedrukt. "
+                     , Str "Hiermee wordt beoogd dat verschillende belanghebbenden hun afspraken op dezelfde manier begrijpen. "
+                     , Str "De taal van ", Quoted  SingleQuote [Str (name fSpec)], Str " bestaat uit begrippen en basiszinnen, "
+                     , Str "waarin afspraken worden uitgedrukt. "
+                     , Str "Wanneer alle belanghebbenden afspreken dat zij deze basiszinnen gebruiken, "
+                     , Str "althans voor zover het ", Quoted  SingleQuote [Str (name fSpec)], Str " betreft, "
+                     , Str "delen zij precies voldoende taal om afspraken op dezelfde manier te begrijpen. "
+                     , Str "Alle definities zijn genummerd omwille van de traceerbaarheid. "
+                     ]]
+        English -> [ Para
+                     [ Str "This chapter defines the natural language, in which functional requirements of "
+                     , Quoted  SingleQuote [Str (name fSpec)]
+                     , Str " can be discussed and expressed. "
+                     , Str "The purpose of this chapter is to create shared understanding among stakeholders. "
+                     , Str "The language of ", Quoted  SingleQuote [Str (name fSpec)], Str " consists of concepts and basic sentences. "
+                     , Str "All functional requirements are expressed in these terms. "
+                     , Str "When stakeholders can agree upon this language, "
+                     , Str "at least within the scope of ", Quoted  SingleQuote [Str (name fSpec)], Str ", "
+                     , Str "they share precisely enough language to have meaningful discussions about functional requirements. "
+                     , Str "All definitions have been numbered for the sake of traceability. "
+                     ]]
+  dpRequirements :: [Block]
+  dpRequirements = theBlocks
+    where
+      (theBlocks,_) = if null (themes fSpec)
+                      then printThemes toBeProcessedStuff newCounter $ map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec)
+                      else printThemes toBeProcessedStuff newCounter $ [ PatternTheme pat | pat<-patterns fSpec, name pat `elem` themes fSpec ] ++
+                                                                       [ ProcessTheme $ fpProc fprc | fprc<-vprocesses fSpec, name fprc `elem` themes fSpec ] 
+      toBeProcessedStuff = ( conceptsWith
+                           , allRelsThatMustBeShown
+                           , [r | r<-vrules fSpec, r_usr r == UserDefined] )  -- All user declared rules
+         where
+           conceptsWith     -- All concepts that have at least one non-empty definition (must be the first)  
+              = [ (c, pps)
+                | c@PlainConcept{cptdf = Cd{cddef=_:_}:_ } <-concs fSpec
+                , let pps = [p | p <- purposesDefinedIn fSpec (language flags) c, explUserdefd p]
+                ]           
+           allRelsThatMustBeShown -- All relations declared in this specification that have at least one user-defined purpose.
+              = [ d | d <- declarations fSpec
+                , decusr d
+                , not . null $ purposesDefinedIn fSpec (language flags) d
+                ]
+                 
+      printThemes :: ( [(A_Concept,[Purpose])]   -- all concepts that have one or more definitions or purposes. These are to be used into this section and the sections to come
+                       , [Declaration]           -- all relations to be processed into this section and the sections to come
+                       , [Rule])                 -- all rules to be processed into this section and the sections to come
+                    -> Counter           -- unique definition counters
+                    -> [Theme]         -- the patterns that must be processed into this specification
+                    -> ([Block],Counter) -- The blocks that define the resulting document and the last used unique definition number
+      printThemes  (still2doCPre, still2doRelsPre, still2doRulesPre) iPre allThemes 
+           = case allThemes of
+              []  -> if null still2doCPre && null still2doRelsPre && null still2doRelsPre
+                     then ([],iPre)
+                     else printOneTheme Nothing (still2doCPre, still2doRelsPre, still2doRulesPre) iPre
+              _   -> (blocksOfOneTheme ++ blocksOfThemes,iPost)
+         where
+           (thm:thms) = allThemes
+           (blocksOfOneTheme,iPostFirst) = printOneTheme (Just thm) thisThemeStuff iPre
+           (blocksOfThemes,iPost)        = printThemes stuff2PrintLater iPostFirst thms
+           thisThemeStuff    = (thisThemeCs, thisThemeRels, [r | r<-thisThemeRules, r_usr r == UserDefined])
+           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` declsUsedIn thisThemeRules] -- all relations used in this theme's rules
+           rels2PrintLater   = [x | x <-still2doRelsPre, (not.or) [ x==y | y <- thisThemeRels ]] 
+           thisThemeCs       = [(c,ps) |(c,ps)<- still2doCPre, c `eleM` (concs thisThemeRules ++ concs thisThemeRels)] -- relations are rules ('Eis') too
+           concs2PrintLater  = still2doCPre >- thisThemeCs
+           stuff2PrintLater  = (concs2PrintLater, rels2PrintLater, rules2PrintLater)
+--           (blocksOfThemes,iPost)     = aThemeAtATime stuff2PrintLater xs iPostFirst
+--           thisThemeStuff = (thisThemeCdefs, thisThemeRels, [r | r<-thisThemeRules, r_usr r])
+--           thisThemeRules = [r | r<-still2doRulesPre, r_env r == name x ]      -- only user defined rules, because generated rules are documented in whatever caused the generation of that rule.
+--           rules2PrintLater = still2doRulesPre >- thisThemeRules
+--           thisThemeRels = [r | r<-still2doRelsPre, r `eleM` declsUsedIn thisThemeRules] `uni`            -- all relations used in this theme's rules
+--                           [ makeRelation d | d<-declarations x, (not.null) (multiplicities d)] -- all relations used in multiplicity rules
+--           rels2PrintLater = still2doRelsPre >- thisThemeRels
+--           thisThemeCdefs = [(c,cd) |(c,cd)<- still2doCdefsPre, c `eleM` (concs thisThemeRules ++ concs thisThemeRels)]
+--           thisThemeCpurps = [(c,ps) |(c,ps)<- still2doCpurpPre, c `eleM` (concs thisThemeRules ++ concs thisThemeRels)]
+--           cDefs2PrintLater = still2doCdefsPre >- thisThemeCdefs
+--           cPurps2PrintLater = still2doCpurpPre >- thisThemeCpurps
+--           stuff2PrintLater = (cDefs2PrintLater, cPurps2PrintLater, rels2PrintLater, rules2PrintLater)
+           
+      -- | printOneTheme tells the story in natural language of a single theme.
+      -- For this purpose, Ampersand authors should take care in composing explanations.
+      -- Each explanation should state the purpose (and nothing else).
+      printOneTheme :: Maybe Theme -- name of the theme to process (if any)
+                    -> ( [(A_Concept,[Purpose])]    -- all concepts that have one or more definitions, to be printed in this section
+                       , [Declaration]          -- Relations to print in this section
+                       , [Rule])             -- Rules to print in this section
+                    -> Counter      -- first free number to use for numbered items
+                    -> ([Block],Counter)-- the resulting blocks and the last used number.
+      printOneTheme mTheme (concs2print, rels2print, rules2print) counter0
+              = case (mTheme, themes fSpec) of
+                 (Nothing, _:_) -> ( [], counter0 )         -- The document is partial (because themes have been defined), so we don't print loose ends.
+                 _              -> ( header' ++ explainsPat ++ printIntro concs2print relConcepts ++ reqdefs
+                                   , Counter (getEisnr counter0 + length reqs)
+                                   )
+           where
+              -- 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)
+              relConcepts = [ (upCap $ name d,def, origin d)
+                            | d@Sgn{decConceptDef=Just (RelConceptDef _ def)} <- rels2print 
+                            ]
+              
+              -- 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 (printRelConcepts relConcepts) ++ 
+                                                 addIndex 2 (printRels rels2print) ++ addIndex 3 (printRules rules2print)]
+               where addIndex i ps = [ (i::Int,fs, sn) | (fs,sn) <- ps ] -- add an index to sort first on category (concept, rel, ..)
+              
+              -- make blocks for requirements
+              reqblocks = [(pos,req (Counter cnt)) | (cnt,(pos,req))<-zip [(getEisnr counter0)..] reqs]
+              reqdefs = concatMap snd reqblocks
+
+              themeName = case mTheme of
+                           Nothing  -> ""
+                           Just pat -> name pat
+                           --Just (PatternTheme pat) -> "Pattern "++name pat
+                           --Just (ProcessTheme prc) -> "Process "++name prc
+              header' :: [Block]
+              header' = toList (labeledThing flags (lev+1) (xLabel DataAnalysis++case mTheme of
+                                                                       Nothing ->  "_LooseEnds"
+                                                                       _       -> themeName
+                                              )
+                                          (case (mTheme,language flags) of
+                                              (Nothing, Dutch  ) -> "Losse eindjes..."
+                                              (Nothing, English) -> "Loose ends..."
+                                              _                  -> themeName
+                                          ))
+                                          
+              explainsPat :: [Block]
+              explainsPat
+               = case mTheme of
+                         Nothing  -> [Para 
+                                      (case language flags of
+                                        Dutch   -> [Str "Deze paragraaf beschrijft de relaties en concepten die niet in voorgaande secties zijn beschreven."]
+                                        English -> [Str "This paragraph shows remaining fact types and concepts "
+                                                   ,Str "that have not been described in previous paragraphs."]
+                                      )]
+                         Just pat -> purposes2Blocks flags purps
+                                     where purps = purposesDefinedIn fSpec (language flags) pat
+
+              printIntro :: [(A_Concept, [Purpose])] -> [(String, String, Origin)] -> [Block]
+              printIntro [] [] = []
+              printIntro ccds relConcpts
+                = case language flags of
+                              Dutch   ->  [Para$ (case ([Emph [Str $ unCap cname] | cname<-map (name . fst) ccds ++ map fst3 relConcpts]
+                                                       , length [p |p <- map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec), name p == themeName]) of
+                                                       ([] ,_) -> []
+                                                       ([_],1) -> [ Str $ "In het volgende wordt de taal geïntroduceerd ten behoeve van "++themeName++". " | themeName/=""]
+                                                       (cs ,1) -> [ Str "Nu volgen definities van de concepten "]++
+                                                                  commaNLPandoc (Str "en") cs++
+                                                                  [ Str ". Daarna worden de basiszinnen en regels geïntroduceerd."]
+                                                       ([c],_) -> [ Str "Deze sectie introduceert het concept "
+                                                                  , c]
+                                                       (cs ,_) -> [ Str "Deze sectie introduceert de concepten "]++
+                                                                  commaNLPandoc (Str "en") cs++
+                                                                  [ Str ". "]
+                                                 )++
+                                                 (let cs = [(c,cds,cps) | (c,cps)<-ccds, let cds = cptdf c,length cds>1] in
+                                                  case (cs, length cs==length ccds) of
+                                                   ([]         ,   _  ) -> []
+                                                   ([(c,_,_)]  , False) -> [ Str $ "Eén daarvan, "++name c++", heeft meerdere definities. " ]
+                                                   (_          , False) -> [ Str "Daarvan hebben "]++commaNLPandoc (Str "en") (map (Str . name . fst3) cs)++[Str " meerdere definities. "]
+                                                   ([(_,cds,_)], True ) -> [ Str $ "Deze heeft "++count flags (length cds) "definitie"++". " ]
+                                                   (_          , True ) -> [ Str "Elk daarvan heeft meerdere definities. "]
+                                                 )
+                                          ]
+                              English ->  [Para$ (case ([Emph [Str $ unCap cname] |cname<-map (name . fst) ccds ++ map fst3 relConcpts]
+                                                       , length [p |p <- map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec), name p == themeName]) of
+                                                       ([] ,_) -> []
+                                                       ([_],1) -> [ Str $ "The sequel introduces the language of "++themeName++". " | themeName/=""]
+                                                       (cs ,1) -> [ Str "At this point, the definitions of "]++
+                                                                  commaEngPandoc (Str "and") cs++
+                                                                  [ Str " are given. Directly after that, the basic sentences and rules are introduced."]
+                                                       ([c],_) -> [ Str "This section introduces concept "
+                                                                  , Emph [c]]
+                                                       (cs ,_) -> [ Str "This section introduces concepts "]++
+                                                                  commaEngPandoc (Str "and") cs++
+                                                                  [ Str ". "]
+                                                 )++
+                                                 (let cs = [(c,cds,cps) | (c,cps)<-ccds, let cds = cptdf c, length cds>1] in
+                                                  case (cs, length cs==length ccds) of
+                                                   ([]         ,   _  ) -> []
+                                                   ([(c,_,_)]  , False) -> [ Str $ "One of these concepts, "++name c++", has multiple definitions. " ]
+                                                   (_          , False) -> [ Str "Of those concepts "]++commaEngPandoc (Str "and") (map (Str . name . fst3) cs)++[Str " have multiple definitions. "]
+                                                   ([(_,cds,_)], True ) -> [ Str $ "It has "++count flags (length cds) "definition"++". " ]
+                                                   (_          , True ) -> [ Str "Each one has several definitions. "]
+                                                 )
+                                          ]
+                  where fst3 (a,_,_) = a
+
+              -- | 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, [Purpose])] -> [(Origin, Counter -> [Block])]
+              printConcepts = let mborigin c = if null(uniquecds c) then OriginUnknown else (origin . snd . head . uniquecds) c
+                      in map (\(c,exps) -> (mborigin c, cptBlock (c,exps)))
+              -- | make a block for a c with all its purposes and definitions
+              cptBlock :: (A_Concept, [Purpose]) -> Counter -> [Block]
+              cptBlock (c,exps) cnt = concat [amPandoc (explMarkup e) | e<-exps] 
+                  ++ zipWith cdBlock
+                       (if length (uniquecds c) == 1 then [(cnt, "")] else
+                          [(cnt, '.' : show i) | i <- [(1 :: Int) ..]])
+                       [ (nm, symDefLabel cd, cddef cd, cdref cd) | (nm, cd) <- uniquecds c ]
+              -- | make a block for a concept definition
+              cdBlock :: (Counter,String) -> (String,String,String,String) -> Block
+              cdBlock (cnt,xcnt) (nm,lbl,def,ref) = DefinitionList 
+                                        [( [ Str (case language flags of
+                                                                 Dutch   -> "Definitie "
+                                                                 English -> "Definition ")
+                                           , Str (show (getEisnr cnt)++xcnt)
+                                           , Str ":"]
+                                         , [ makeDefinition flags (getEisnr cnt)  nm lbl def ref ])]
+
+              printRelConcepts :: [(String, String, Origin)] -> [(Origin, Counter -> [Block])]
+              printRelConcepts relConcpts = map printRelConcept relConcpts
+              
+              printRelConcept (relcncpt, def, org) = 
+                ( org, \cnt -> [cdBlock (cnt,"") (relcncpt, "", def, "")]
+                )
+
+              -- | 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"] :
+                 purposes2Blocks flags purps
+                 ++ 
+                 [ DefinitionList [ ( [ Str (case language flags of
+                                                      Dutch   -> "Afspraak "
+                                                      English -> "Agreement ")
+                                     , Str (show(getEisnr cnt))
+                                     ,if development flags && name dcl/="" then Str (" ("++name dcl++"):") else Str ":"]
+                                   , [ Plain [RawInline (Text.Pandoc.Builder.Format "latex") $ symReqLabel dcl]:
+                                       meaning2Blocks (language flags) dcl
+                                     ]
+                                   )] ]++
+                 ( case (language flags, 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 (language flags) dcl
+                       samplePop = take 3 (fullContents (gens fSpec) (initialPops fSpec) dcl)
+                       sampleSentences =
+                         [ Para $ mkSentence (development flags) dcl srcViewAtom tgtViewAtom 
+                         | (srcAtom,tgtAtom)<-samplePop
+                         , let srcViewAtom = showViewAtom fSpec (Just dcl) (source dcl) srcAtom 
+                         , let tgtViewAtom = showViewAtom fSpec Nothing (target dcl) tgtAtom
+                         ] ++
+                         (if null samplePop then [] else [Plain [RawInline (Text.Pandoc.Builder.Format "latex") "\\medskip"]])
+
+              printRules :: [Rule] -> [(Origin,Counter -> [Block])]
+              printRules = map (\rul -> (origin rul, printRule rul))
+
+  printRule :: Rule -> Counter -> [Block]
+  printRule rul cnt 
+   =  Plain [RawInline (Text.Pandoc.Builder.Format "latex") "\\bigskip"] :
+      purposes2Blocks flags purps
+      ++
+      [ DefinitionList [ ( [ Str (case language flags of
+                                    Dutch   -> "Afspraak "
+                                    English -> "Agreement ")
+                           , Str (show(getEisnr cnt))
+                           , if development flags && name rul/="" then Str (" ("++name rul++"):") else Str ":"]
+                         , [ Plain [ RawInline (Text.Pandoc.Builder.Format "latex") $ symReqLabel rul] :
+                                       meaning2Blocks (language flags) rul
+                           ]
+                         )
+                       ] 
+      | not (null$meaning2Blocks (language flags) rul)]
+   where purps = purposesDefinedIn fSpec (language flags) rul
+          
+  mkSentence :: Bool -> Declaration -> String -> String -> [Inline]
+  mkSentence isDev decl srcAtom tgtAtom
+   = case decl of
+       Sgn{} | null (prL++prM++prR) 
+                  -> [str (upCap srcAtom), Space] ++ devShow (source decl) ++ [Str "corresponds",Space,Str "to",Space,str tgtAtom, Space] ++ devShow (target decl) ++[Str "in",Space,Str "relation",Space,str (decnm decl),Str "."]
+             | otherwise 
+                  -> leftHalf prL ++ rightHalf
+                    where prL = decprL decl
+                          prM = decprM decl
+                          prR = decprR decl
+                          leftHalf ""    = devShow (source decl)
+                          leftHalf prLft = [str (upCap prLft), Space] ++ devShow (source decl)
+                          rightHalf = [str srcAtom,Space,str prM, Space] ++ devShow (target decl) ++ [str tgtAtom]++(if null prR then [] else [Space,str prR]) ++ [Str "."]
+
+       Isn{}     -> devShow (source decl) ++ [str (upCap srcAtom),Space,Str "equals",Space,str tgtAtom,Str "."]
+       Vs{}      -> [Str "True"]
+   where str = if fspecFormat flags==FLatex then RawInline (Text.Pandoc.Builder.Format "latex") . latexEscShw else Str
+         devShow c | isDev     = [Str "(", str $ name c, Str ") "] -- only show the concept when --dev option is given
+                   | otherwise = []
+
+-- TODO: fix showing/not showing based on relation
+-- TODO: what about relations in the target view?
+-- TODO: move these to some auxiliaries or utils
+showViewAtom :: Fspc -> Maybe Declaration -> A_Concept -> String -> String
+showViewAtom fSpec mDec cncpt atom =
+  case mapMaybe (getView fSpec) (cncpt : largerConcepts (gens fSpec) cncpt) of
+    []    -> atom
+    view:_ -> case mDec of
+              Nothing -> concatMap showViewSegment (vdats view)
+              Just md -> if (not.null) [() | ViewExp objDef <- vdats view, EDcD d<-[objctx objDef], d==md]
+                         then atom
+                         else concatMap showViewSegment (vdats view)
+             -- if we are showing one of the view relations, don't expand the view
+     where showViewSegment (ViewText str) = str
+           showViewSegment (ViewHtml str) = str
+           showViewSegment (ViewExp objDef) = 
+             case [ tgtAtom | (srcAtom, tgtAtom) <- fullContents (gens fSpec) (initialPops fSpec) (objctx objDef), atom == srcAtom ] of
+               []         -> ""
+               viewAtom:_ -> viewAtom  
+        -- justViewRels = map (Just . objctx) [objDef | ViewExp objDef <- vdats view]
+
+{-
+getIdentity :: Fspc -> A_Concept -> Maybe IdentityDef
+getIdentity fSpec cncpt = 
+  case filter ((== cncpt) .  idCpt) (vIndices fSpec) of
+    []         -> Nothing 
+    identity:_ -> Just identity 
+-}
+
+getView :: Fspc -> A_Concept -> Maybe ViewDef
+getView fSpec cncpt = 
+  case filter ((== cncpt) .  vdcpt) (vviews fSpec) of
+    []       -> Nothing 
+    viewDef:_ -> Just viewDef
+ src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterProcessAnalysis.hs view
@@ -0,0 +1,178 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterProcessAnalysis
+where
+import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
+import DatabaseDesign.Ampersand.Classes
+import Data.List
+import DatabaseDesign.Ampersand.Output.PandocAux
+
+--DESCR -> the process analysis contains a section for each process in the fspec
+-- If an Ampersand script contains no reference to any role whatsoever, a process analysis is meaningless.
+-- In that case it will not be printed. To detect whether this is the case, we can look whether the
+-- mayEdit attributes remain empty.
+noProcesses :: Fspc -> Bool
+noProcesses fSpec = null (fRoleRels fSpec) && null (fRoleRuls fSpec)
+
+chpProcessAnalysis :: Int -> Fspc -> Options -> (Blocks,[Picture])
+chpProcessAnalysis lev fSpec flags
+ = if null procs
+   then (mempty,[])
+   else (fromList $ header ++ roleRuleBlocks ++ roleRelationBlocks ++ processSections , pictures)
+ where
+  pictures = [pict | (_,picts)<-procSections procs,pict<-picts]
+  procs = if null (themes fSpec)
+          then vprocesses fSpec
+          else [ prc | prc<-vprocesses fSpec, name prc `elem` themes fSpec ]
+  processSections :: [Block]
+  processSections
+   = [block | (bs,_)<-procSections procs, block<-bs]
+
+  header :: [Block]
+  header
+   = toList (chptHeader flags ProcessAnalysis) ++
+     purposes2Blocks flags purps ++ -- This explains the purpose of this context.
+     [ case language flags 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)] ++
+     [ case language flags of
+         Dutch   ->
+            Plain [ Str $ upCap (name fSpec)++" specificeert niet welke rollen de inhoud van welke relaties mogen wijzigen. "
+                  , Str ""
+                  ]
+         English ->
+            Plain [ Str $ upCap (name fSpec)++" does not specify which roles may change the contents of which relations. "
+                  , Str ""
+                  ]
+     | null (fRoleRels fSpec)]
+     where purps = purposesDefinedIn fSpec (language flags) fSpec
+
+  roleRuleBlocks :: [Block]
+  roleRuleBlocks
+   = if null (fRoleRuls fSpec) && (not.null.udefrules) fSpec then [] else
+     [ case language flags of
+          Dutch   ->
+            Para [ Str $ upCap (name fSpec)++" kent regels aan rollen toe. "
+                 , Str "De volgende tabel toont de regels die door een bepaalde rol worden gehandhaafd."
+                 ]
+          English ->
+            Para [ Str $ upCap (name fSpec)++" assigns rules to roles. "
+                 , Str "The following table shows the rules that are being maintained by a given role."
+                 ]
+-- the table containing the role-rule assignments
+     , Para  $ [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "\\begin{tabular}{|l|l|}\\hline\n"
+               , case language flags of
+                  Dutch   -> RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "Rol&Regel\\\\ \\hline\n"
+                  English -> RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "Role&Rule\\\\ \\hline\n"
+               ]++
+               [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ intercalate "\\\\ \\hline\n   " 
+                       [ role++" & "++name r++
+                         concat[ "\\\\\n   &"++name rul | rul<-map snd (tail rrClass)]
+                       | rrClass<-eqCl fst (fRoleRuls fSpec)
+                       , let role=fst (head rrClass), let r=snd (head rrClass)
+                       ]
+               ]++
+               [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "\\\\ \\hline\n\\end{tabular}"
+               ]
+     ]
+
+-- the table containing the role-relation assignments
+  roleRelationBlocks :: [Block]
+  roleRelationBlocks
+   = if null (fRoleRels fSpec) then [] else
+     [ case language flags of
+          Dutch   ->
+            Para [ Str $ upCap (name fSpec)++" kent rollen aan relaties toe. "
+                 , Str "De volgende tabel toont de relaties waarvan de inhoud gewijzigd kan worden door iemand die een bepaalde rol vervult."
+                 ]
+          English ->
+            Para [ Str $ upCap (name fSpec)++" assigns roles to relations. "
+                 , Str "The following table shows the relations, the content of which can be altered by anyone who fulfills a given role."
+                 ]
+     , Para  $ [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "\\begin{tabular}{|l|l|}\\hline\n"
+               , RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex")
+                    (case  language flags of
+                       Dutch   -> "Rol&Relatie\\\\ \\hline\n"
+                       English -> "Role&Relation\\\\ \\hline\n")
+               ]++
+               [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ intercalate "\\\\ \\hline\n   " 
+                       [ role++" & $"++showMath r++"$"++
+                         concat[ "\\\\\n   &$"++showMath (snd rs)++"$" | rs<-tail rrClass]
+                       | rrClass<-eqCl fst (fRoleRels fSpec)
+                       , let role=fst (head rrClass), let r=snd (head rrClass)
+                       ]
+               ]++
+               [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "\\\\ \\hline\n" | not (null rolelessRels)]++
+               [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ intercalate "\\\\\n   " [ "&$"++showMath d++"$" | d<-rolelessRels] | not (null rolelessRels)]++
+               [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "\\\\ \\hline\n\\end{tabular}"
+               ]
+     ]
+     where
+      rolelessRels = [ d | d<-declarations fSpec, d `notElem` (nub.map snd) (fRoleRels fSpec) ]
+
+  emptyProcess :: Process -> Bool
+  emptyProcess p = null (udefrules p)
+  
+-- the sections in which processes are analyzed
+  procSections :: [FProcess] -> [([Block],[Picture])]
+  procSections fprocs = iterat [fp |fp<-fprocs, not (emptyProcess (fpProc fp))] 1 (concs (patterns fSpec)) ((concatMap declarations.patterns) fSpec)
+   where
+    iterat :: [FProcess] -> Int -> [A_Concept] -> [Declaration] -> [([Block],[Picture])]
+    iterat [] _ _ _ = []
+    iterat (fproc:fps) i seenConcepts seenDeclarations
+     = (  toList (labeledThing flags (lev+1) (xLabel ProcessAnalysis++"_"++name fproc) (name fproc))    -- new section to explain this theme
+       ++ sctMotivation                       -- The section startss with the reason why this process exists,
+       ++ txtProcessModel fproc
+       ++ txtLangModel fproc
+       ++ (if null sctRules then [] else [DefinitionList sctRules])
+       , [picProcessModel fproc, picLangModel fproc]):  iterat fps i' seenCrs seenDrs
+       where
+         sctMotivation
+          = purposes2Blocks flags purps
+         purps = purposesDefinedIn fSpec (language flags) fproc
+         sctRules :: [([Inline], [[Block]])]
+         (sctRules,i',seenCrs,seenDrs) = dpRule fSpec flags (udefrules (fpProc fproc)) i seenConcepts seenDeclarations
+
+  txtLangModel :: FProcess->[Block]
+  txtLangModel fp
+   = if not (genGraphics flags) then [] else
+     -- (if name ifc==name (head (fActivities fSpec)) then processModelIntro else [])++
+      [Para (case language flags of                                     -- announce the conceptual diagram
+             Dutch   -> [ Str "Het conceptueel diagram in figuur ", xrefReference pict
+                        , Str " geeft een overzicht van de taal waarin dit proces wordt uitgedrukt."]
+             English -> [ Str "The conceptual diagram of figure ", xrefReference pict
+                        , Str " provides an overview of the language in which this process is expressed."])
+      ,Plain (xrefFigure1 pict)]                     -- draw the diagram
+     where pict = picLangModel fp
+
+  txtProcessModel :: FProcess->[Block]
+  txtProcessModel p
+   = if not (genGraphics flags) then [] else
+     -- (if name ifc==name (head (fActivities fSpec)) then processModelIntro else [])++
+     [Para (case language flags of                                     -- announce the processModel diagram
+             Dutch   -> [ Str "Figuur ", xrefReference pict
+                        , Str " geeft het procesmodel weer."]
+             English -> [ Str "Figure ", xrefReference pict
+                        , Str " shows the process model."])
+     ,Plain (xrefFigure1 pict)]                     -- draw the diagram
+     where pict = picProcessModel p
+
+  picLangModel :: FProcess->Picture
+  picLangModel fproc
+   = ((makePictureObj flags (name fproc) PTProcLang . conceptualGraph fSpec flags Rel_CG) fproc)   -- the Picture that represents this process's knowledge graph with all user defined relations (controlled by Rel_CG)
+                {caption = case language flags of
+                            Dutch   ->"Basiszinnen van "++name fproc
+                            English ->"Basic sentences of "++name fproc}
+
+  picProcessModel :: FProcess->Picture
+  picProcessModel fproc
+   = makePicture flags fSpec Plain_CG fproc -- the Picture that represents this interface's knowledge graph with only those relations that are used in rules (controlled by Plain_CG).
+
+
+ src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterSoftwareMetrics.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterSoftwareMetrics
+where
+import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
+import DatabaseDesign.Ampersand.Output.Statistics (Statistics(..))
+import DatabaseDesign.Ampersand.Output.PandocAux
+
+
+------------------ Function Point Analysis --------------------
+-- TODO: Engels en Nederlands netjes scheiden.
+-- TODO: Andere formaten dan LaTeX ondersteunen.
+
+fpAnalysis :: Fspc -> Options ->  Blocks
+fpAnalysis fSpec flags = mempty -- if null (themes fSpec) then header ++ caIntro ++ fpa2Blocks else []
+ where 
+  header :: Blocks
+  header = chptHeader flags SoftwareMetrics
+  caIntro :: [Block]
+  caIntro = 
+   case language flags of
+      Dutch   -> [Para
+                  [ Str "De specificatie van "
+                  , Quoted  SingleQuote [Str (name fSpec)]
+                  , Str " is geanalyseerd door middel van een functiepuntentelling"
+                  , xrefCitation "IFPUG"
+                  , Str ". "
+                  , Str $ "Dit heeft geresulteerd in een geschat totaal van "++(show.nFpoints) fSpec++" functiepunten."
+                  ]]
+      English -> [Para
+                  [ Str "The specification of "
+                  , Quoted  SingleQuote [Str (name fSpec)]
+                  , Str " has been analysed by counting function points"
+                  , xrefCitation "IFPUG"
+                  , Str ". "
+                  , Str $ "This has resulted in an estimated total of "++(show.nFpoints) fSpec++" function points."
+                  ]]
+   
+
+  fpa2Blocks' :: [Block]
+  fpa2Blocks' = []
+--   = [ Table [] [AlignLeft,AlignLeft,AlignRight] [0.0,0.0,0.0]
+--             ( case language flags of
+--                 Dutch   -> [ [Plain [Str "gegevensverzameling"]]
+--                            , [Plain [Str "analyse"]]
+--                            , [Plain [Str "FP"]]]
+--                 English -> [ [Plain [Str "data set"]]
+--                            , [Plain [Str "analysis"]]
+--                            , [Plain [Str "FP"]]]
+--             )
+--             [ [ [Plain [(Str . name)                 plug]]
+--               , [Plain [(Str . show . fpa)           plug]]
+--               , [Plain [(Str . show . fPoints . fpa) plug]]
+--               ]
+--             | plug<-plugInfos fSpec, fPoints (fpa plug)>0
+--             ]
+--     , Table [] [AlignLeft,AlignLeft,AlignRight] [0.0,0.0,0.0]
+--             ( case language flags of
+--                Dutch   ->
+--                    [ [Plain [Str "interface"]]
+--                    , [Plain [Str "analyse"]]
+--                    , [Plain [Str "FP"]]]
+--                English ->
+--                    [ [Plain [Str "interface"]]
+--                    , [Plain [Str "analysis"]]
+--                    , [Plain [Str "FP"]]]
+--             )
+--             [ [ [Plain [(Str . name)                    act]]
+--               , [Plain [(Str . show . actFPA)           act]]
+--               , [Plain [(Str . show . fPoints . actFPA) act]]]
+--             | act<-fActivities fSpec
+--             ]
+--     ]            
+
+ src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/SharedAmongChapters.hs view
@@ -0,0 +1,365 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters 
+    ( module Text.Pandoc
+    , module Text.Pandoc.Builder
+    , bulletList -- (is redefined in this module, but belongs in Text.Pandoc.Builder.)
+    , math -- 
+    , module Data.Monoid
+    , module DatabaseDesign.Ampersand.Basics  
+    , module DatabaseDesign.Ampersand.Fspec
+    , module DatabaseDesign.Ampersand.Misc
+    , module DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
+    , Chapter(..)
+    , chaptersInDoc
+    , chptHeader
+    , chptTitle
+    , Xreferencable(..)
+    , xrefFigure1
+    , showImage
+    , canXRefer
+    , Purpose(..)
+    , purposes2Blocks
+    , isMissing
+    , lclForLang
+    , dpRule
+    , Counter(..),newCounter,incEis
+    , inlineIntercalate
+    )
+where
+import DatabaseDesign.Ampersand.Basics  
+import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (Meta)
+import DatabaseDesign.Ampersand.ADL1
+import DatabaseDesign.Ampersand.Classes
+import DatabaseDesign.Ampersand.Fspec
+import Text.Pandoc
+import Text.Pandoc.Builder hiding (bulletList,math)
+import qualified Text.Pandoc.Builder as  BuggyBuilder
+import DatabaseDesign.Ampersand.Output.PredLogic        (PredLogicShow(..), showLatex)
+import DatabaseDesign.Ampersand.Misc
+import DatabaseDesign.Ampersand.Output.PandocAux
+import Data.List             (intercalate,partition)
+import Data.Monoid
+import System.Locale
+
+fatal :: Int -> String -> a
+fatal = fatalMsg "Output.ToPandoc.SharedAmongChapters"
+
+data Chapter = Intro 
+             | SharedLang
+             | Diagnosis 
+             | ConceptualAnalysis
+             | ProcessAnalysis
+             | DataAnalysis
+             | SoftwareMetrics
+             | EcaRules
+             | Interfaces
+             | Glossary
+             deriving (Eq, Show)
+
+-- | Define the order of the chapters in the document.
+chaptersInDoc :: Options -> [Chapter]  
+chaptersInDoc flags = [chp | chp<-chapters, chp `notElem` disabled]
+ where
+   -- temporarily switch off chapters that need too much refactoring, but keep this Haskell code compilable.
+    disabled = [EcaRules,Interfaces]
+    chapters
+     | test flags                  = [SharedLang]
+     | diagnosisOnly flags         = [Diagnosis]
+     | theme flags == StudentTheme = [Intro,SharedLang,Diagnosis,ConceptualAnalysis,DataAnalysis]
+     | otherwise                   = [ Intro 
+                                     , SharedLang
+                                     , Diagnosis 
+                                     , ConceptualAnalysis
+                                     , ProcessAnalysis
+                                     , DataAnalysis
+                                     , SoftwareMetrics
+                                     , EcaRules
+                                     , Interfaces
+                                     , Glossary
+                                     ]
+
+-- | This function returns a header of a chapter
+chptHeader :: Options -> Chapter -> Blocks
+chptHeader flags cpt 
+ = header 1 (chptTitle flags cpt )
+ 
+chptTitle :: Options -> Chapter -> Inlines
+chptTitle flags cpt =
+     (case (cpt,language flags) of
+        (Intro             , Dutch  ) -> text "Inleiding"
+        (Intro             , English) -> text "Introduction"
+        (SharedLang        , Dutch  ) -> text "Gemeenschappelijke taal"
+        (SharedLang        , English) -> text "Shared Language"
+        (Diagnosis         , Dutch  ) -> text "Diagnose" 
+        (Diagnosis         , English) -> text "Diagnosis" 
+        (ConceptualAnalysis, Dutch  ) -> text "Conceptuele Analyse"
+        (ConceptualAnalysis, English) -> text "Conceptual Analysis"
+        (ProcessAnalysis   , Dutch  ) -> text "Procesanalyse"
+        (ProcessAnalysis   , English) -> text "Process Analysis"
+        (DataAnalysis      , Dutch  ) -> text "Gegevensstructuur"
+        (DataAnalysis      , English) -> text "Data structure"
+        (SoftwareMetrics   , Dutch  ) -> text "Functiepunt Analyse"
+        (SoftwareMetrics   , English) -> text "Function Point Analysis"
+        (EcaRules          , Dutch  ) -> text "ECA regels" 
+        (EcaRules          , English) -> text "ECA rules (Flash points)" 
+        (Interfaces        , Dutch  ) -> text "Koppelvlakken" 
+        (Interfaces        , English) -> text "Interfaces"
+        (Glossary          , Dutch  ) -> text "Begrippen"
+        (Glossary          , English) -> text "Glossary"
+     )
+
+class Xreferencable a where
+  xLabel :: a  -> String
+  xrefReference :: a  -> Inline   --Depreciated! TODO: use xRefReference instead
+  xrefReference a = RawInline (Text.Pandoc.Builder.Format "latex") ("\\ref{"++xLabel a++"}")
+  xRefReference :: Options -> a -> Inlines
+  xRefReference flags a 
+    | canXRefer flags = rawInline "latex" ("\\ref{"++xLabel a++"}")
+    | otherwise       = mempty -- "fatal 89 xreferencing is not supported!"
+  xrefLabel :: a -> Inline
+  xrefLabel a = RawInline (Text.Pandoc.Builder.Format "latex") ("\\label{"++xLabel a++"}")
+
+canXRefer :: Options -> Bool
+canXRefer opts = fspecFormat opts `elem` [FLatex] 
+
+instance Xreferencable Chapter where
+  xLabel a = "chapter" ++ escapeNonAlphaNum (show a)
+  
+instance Xreferencable Picture where
+  xLabel a = "figure" ++ escapeNonAlphaNum (uniqueName a)
+
+--Image [Inline] Target
+--      alt.text (URL,title)
+showImage :: Options -> Picture -> Inlines
+showImage flags pict = 
+      case fspecFormat flags of
+         FLatex  -> rawInline "latex" ("\\begin{figure}[htb]\n\\begin{center}\n\\scalebox{"++scale pict++"}["++scale pict++"]{")
+         _       -> mempty
+   <> image (uniqueName pict) (xLabel pict) (text $ "Here, "++uniqueName pict++" should have been visible" )
+   <> case fspecFormat flags of
+         FLatex  -> rawInline "latex" "}\n"
+                  <>rawInline "latex" ("\\caption{"++latexEscShw (caption pict)++"}\n") 
+         _       -> mempty
+   <> singleton (xrefLabel pict)
+   <> case fspecFormat flags of
+         FLatex  -> rawInline "latex" "\n\\end{center}\n\\end{figure}"
+         _       -> mempty
+xrefFigure1 :: Picture -> [Inline]  --DEPRECIATED! Use showImage instead.
+xrefFigure1 pict =
+   [ RawInline (Text.Pandoc.Builder.Format "latex") ("\\begin{figure}[htb]\n\\begin{center}\n\\scalebox{"++scale pict++"}["++scale pict++"]{")
+   , Image [Str $ "Here, "++uniqueName pict++" should have been visible"] (uniqueName pict, xLabel pict)
+   , RawInline (Text.Pandoc.Builder.Format "latex") "}\n"
+   , RawInline (Text.Pandoc.Builder.Format "latex") ("\\caption{"++latexEscShw (caption pict)++"}\n") 
+   , xrefLabel pict
+   , RawInline (Text.Pandoc.Builder.Format "latex") "\n\\end{center}\n\\end{figure}"]
+
+-- | This function orders the content to print by theme. It returns a list of 
+--   tripples by theme. The last tripple might not have a theme, but will contain everything
+--   that isn't handled in a specific theme.
+orderingByTheme :: Fspc -> [( Maybe Theme   -- A theme is about either a pattern of a process. 
+                            , [Rule]        -- The rules of that theme
+                            , [Declaration] -- The relations that are used in a rule of this theme, but not in any rule of a previous theme.
+                            , [A_Concept]   -- The concepts that are used in a rule of this theme, but not in any rule of a previous theme.
+                            )
+                           ]
+orderingByTheme fSpec 
+ = f (allRules fSpec) (declsUsedIn fSpec) (allConcepts fSpec) tms
+ where
+  -- | The themes that should be taken into account for this ordering
+  tms = if null (themes fSpec)
+        then map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec)
+        else [ PatternTheme pat           | pat <-patterns   fSpec, name pat  `elem` themes fSpec ]
+           ++[ ProcessTheme (fpProc fprc) | fprc<-vprocesses fSpec, name fprc `elem` themes fSpec ] 
+  f ruls rels cpts ts
+   = case ts of
+       t:ts' -> let ( (rulsOfTheme,rulsNotOfTheme)
+                     , (relsOfTheme,relsNotOfTheme)
+                     , (cptsOfTheme,cptsNotOfTheme)
+                     ) = partitionByTheme t ruls rels cpts 
+                in (Just t, rulsOfTheme, relsOfTheme, cptsOfTheme)
+                   : f rulsNotOfTheme relsNotOfTheme cptsNotOfTheme ts'
+       []    -> [(Nothing, ruls, rels, cpts)]
+  -- | This function takes care of partitioning each of the 
+  --   lists in a pair of lists of elements which do and do not belong
+  --   to the theme, respectively 
+  partitionByTheme :: Theme
+                   -> [Rule]
+                   -> [Declaration]
+                   -> [A_Concept]
+                   -> ( ([Rule],[Rule])
+                      , ([Declaration],[Declaration])
+                      , ([A_Concept],[A_Concept])
+                      )
+  partitionByTheme thme ruls rels cpts
+      = ((rulsOfTheme,rulsNotOfTheme), (relsOfTheme,relsNotOfTheme), (cptsOfTheme,cptsNotOfTheme))
+     where 
+       (rulsOfTheme,rulsNotOfTheme) = partition isRulOfTheme ruls
+       isRulOfTheme r = r `elem` (case thme of
+                                    PatternTheme pat -> ptrls pat
+                                    ProcessTheme prc -> prcRules prc
+                                 )
+       (relsOfTheme,relsNotOfTheme) = partition isRelOfTheme rels
+       isRelOfTheme r = r `elem` concatMap declsUsedIn rulsOfTheme
+       (cptsOfTheme,cptsNotOfTheme) = partition isCptOfTheme cpts
+       isCptOfTheme c = c `elem` concatMap concs relsOfTheme
+        
+        
+--GMI: What's the meaning of the Int?
+dpRule :: Fspc -> Options -> [Rule] -> Int -> [A_Concept] -> [Declaration]
+          -> ([([Inline], [[Block]])], Int, [A_Concept], [Declaration])
+dpRule fSpec flags = dpR
+ where
+   dpR [] n seenConcs seenDeclarations = ([], n, seenConcs, seenDeclarations)
+   dpR (r:rs) n seenConcs seenDeclarations
+     = ( ( [Str (name r)]
+         , [ let purps = purposesDefinedIn fSpec (language flags) r in            -- Als eerste de uitleg van de betreffende regel..
+             purposes2Blocks flags purps ++
+             purposes2Blocks flags [p | d<-nds, p<-purposesDefinedIn fSpec (language flags) d] ++  -- Dan de uitleg van de betreffende relaties
+             [ Plain text1 | not (null nds)] ++
+             pandocEqnArray [ ( texOnly_Id(name d)
+                              , ":"
+                              , texOnly_Id(name (source d))++(if isFunction d then texOnly_fun else texOnly_rel)++texOnly_Id(name(target d))++symDefLabel d
+                              )
+                            |d<-nds] ++
+             [ Plain text2 | not (null rds)] ++
+             [ Plain text3 ] ++
+             (if showPredExpr flags
+              then pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r)
+              else pandocEquation (showMath r++symDefLabel r)
+             )++
+             (if length nds>1 then text5 else [])
+           ] 
+         ): dpNext
+       , n'
+       , seenCs 
+       , seenDs
+       )
+       where
+        text1
+         = case (length nds,language flags) of
+             (1,Dutch)   -> let d = head nds in
+                            [Str ("Om dit te formaliseren is een "++(if isFunction d then "functie" else "relatie")++" "),Str (name d),Str " nodig (",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef d,Str "):"]
+             (1,English) -> let d = head nds in
+                            [Str "In order to formalize this, a ", Str (if isFunction d then "function" else "relation"), Space, Str (name d),Str " is introduced (",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef d,Str "):"]
+             (l,Dutch)   -> [Str "Om te komen tot de formalisatie in vergelijking",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef r,Str (" zijn de volgende "++count flags l "relatie"++" nodig.")]
+             (l,English) -> [Str "To arrive at the formalization in equation",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef r,Str (", the following "++count flags l "relation"++" are introduced.")]
+        text2
+         = (case (length nds,length rds,language flags) of
+             (0,1,Dutch)   -> [Str "Definitie ",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef (head rds), Space, Str "(", Str (name (head rds)), Str ") wordt gebruikt"]
+             (0,1,English) -> [Str "We use definition ",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef (head rds), Space, Str "(", Str (name (head rds)), Str ")"]
+             (0,_,Dutch)   -> Str "We gebruiken definities ":commaNLPandoc (Str "en") [RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef d++" ("++texOnly_Id (name d)++")" |d<-rds]
+             (0,_,English) -> Str "We use definitions ":commaEngPandoc (Str "and") [RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef d++" ("++texOnly_Id (name d)++")" |d<-rds]
+             (_,1,Dutch)   -> [Str "Daarnaast gebruiken we definitie ",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef (head rds), Space, Str "(", Str (name (head rds)), Str ")"]
+             (_,1,English) -> [Str "Beside that, we use definition ",RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef (head rds), Space, Str "(", Str (name (head rds)), Str ")"]
+             (_,_,Dutch)   -> Str "Ook gebruiken we definities ":commaNLPandoc (Str "en") [RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef d++" ("++texOnly_Id (name d)++")" |d<-rds]
+             (_,_,English) -> Str "We also use definitions ":commaEngPandoc (Str "and") [RawInline (Text.Pandoc.Builder.Format "latex") $ symDefRef d++" ("++texOnly_Id (name d)++")" |d<-rds]
+           )++
+           (case (length nds,language flags) of
+             (1,Dutch)   -> [Str " om eis",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqRef r, Str " (pg.",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str ") te formaliseren:"]
+             (1,English) -> [Str " to formalize requirement",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqRef r, Str " (page",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str "):"]
+             _           -> [Str ". "]
+           )
+        text3
+         = case (language flags,isSignal r) of
+            (Dutch  ,False) -> [Str "De regel luidt: "]
+            (English,False) -> [Str "This means: "]
+            (Dutch  ,True)  -> [Str "Activiteiten, die door deze regel zijn gedefinieerd, zijn afgerond zodra: "]
+            (English,True)  -> [Str "Activities that are defined by this rule are finished when: "]
+        text4
+         = case language flags of
+                 Dutch   -> [Str " Deze activiteiten worden opgestart door:"]
+                 English -> [Str " These activities are signalled by:"]
+        text5
+         = case (language flags,isSignal r) of
+             (Dutch  ,False) -> [ Plain [ Str "Dit komt overeen met de afspraak op pg.",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str ":"]]++meaning2Blocks (language flags) r
+             (English,False) -> [ Plain [ Str "This corresponds to the requirement on page",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str ":"]]++meaning2Blocks (language flags) r
+             (Dutch  ,True)  -> [ Plain [ Str "Dit komt overeen met "
+                                        , Quoted  SingleQuote [Str (name r)]
+                                        , Str " (",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqRef r, Str " op pg.",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str ")."]]
+             (English,True)  -> [ Plain [ Str "This corresponds to "
+                                        , Quoted  SingleQuote [Str (name r)]
+                                        , Str " (",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqRef r, Str " op pg.",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str ")."]]
+        ncs = concs r >- seenConcs            -- newly seen concepts
+        cds = [(c,cd) | c<-ncs, cd<-conceptDefs fSpec, cdcpt cd==name c]    -- ... and their definitions
+        ds  =  declsUsedIn r
+        nds = [d | d@Sgn{}<-ds >- seenDeclarations]     -- newly seen declarations
+        rds = [d | d@Sgn{}<-ds `isc` seenDeclarations]  -- previously seen declarations
+        ( dpNext, n', seenCs,  seenDs ) = dpR rs (n+length cds+length nds+1) (ncs++seenConcs) (nds++seenDeclarations)
+
+
+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] -> [Block]
+purposes2Blocks flags ps
+ = case ps of
+    [] -> []
+          -- by putting the ref after the first inline of the definition, it aligns nicely with the definition
+    _  -> case concatMarkup [expl{amPandoc = insertAfterFirstInline (ref purp) $ amPandoc expl} | purp<-ps, let expl=explMarkup purp] of
+           Nothing -> []
+           Just p  -> amPandoc p
+   where   -- The reference information, if available for this purpose, is put
+    ref purp = case fspecFormat flags of
+                FLatex | (not.null.explRefId) purp-> [RawInline (Text.Pandoc.Builder.Format "latex") ("\\marge{"++latexEscShw (explRefId purp)++"}\n")]
+                _                                 -> []
+concatMarkup :: [A_Markup] -> Maybe A_Markup
+concatMarkup es
+ = case eqCl f es of
+    []   -> Nothing
+    [cl] -> Just A_Markup { amLang   = amLang (head cl)
+                          , amFormat = amFormat (head cl)
+                          , amPandoc = concatMap amPandoc es
+                          }
+    cls  -> fatal 136 ("don't call concatMarkup with different languages and formats\n   "++
+                      intercalate "\n   " [(show.f.head) cl | cl<-cls])
+   where f e = (amLang e, amFormat e)
+
+
+-- Insert an inline after the first inline in the list of blocks, if possible. 
+insertAfterFirstInline :: [Inline] -> [Block] -> [Block]
+insertAfterFirstInline inlines (            Plain (inl:inls):pblocks)        =             Plain (inl : (inlines++inls)) : pblocks
+insertAfterFirstInline inlines (            Para (inl:inls):pblocks)         =             Para (inl : (inlines++inls)) : pblocks
+insertAfterFirstInline inlines (BlockQuote (Para (inl:inls):pblocks):blocks) = BlockQuote (Para (inl : (inlines++inls)) : pblocks):blocks
+insertAfterFirstInline inlines blocks                                        = Plain inlines : blocks
+
+isMissing :: Maybe Purpose -> Bool
+isMissing mp =
+  case mp of 
+    Nothing -> True
+    Just p  -> (not . explUserdefd) p
+
+lclForLang :: Options -> TimeLocale
+lclForLang flags = defaultTimeLocale { months =
+         case language flags of
+           Dutch   -> [ ("januari","jan"),("februari","feb"),("maart","mrt"),("april","apr")
+                      , ("mei","mei"),("juni","jun"),("juli","jul"),("augustus","aug")
+                      , ("september","sep"),("oktober","okt"),("november","nov"),("december","dec")]
+           English -> [ ("January","Jan"),("February","Feb"),("March","Mar"),("April","Apr")
+                      , ("May","May"),("June","Jun"),("July","Jul"),("August","Aug")
+                      , ("September","Sep"),("October","Oct"),("November","Nov"),("December","Dec")]
+           }
+
+
+inlineIntercalate :: Inlines -> [Inlines] -> Inlines
+inlineIntercalate _  [] = mempty
+inlineIntercalate _ [x] = x
+inlineIntercalate sep (x:xs) = x <> sep <> inlineIntercalate sep xs
+
+-- Temporary fixes of Pandoc builder. ---  
+bulletList :: [Blocks] -> Blocks
+bulletList [] = mempty
+bulletList xs = BuggyBuilder.bulletList xs
+
+math :: String -> Inlines
+math s = BuggyBuilder.math ("{"++s++"}")