Merge pull request #761 from AmpersandTarski/development

Merge to release 3.9.4

.gitignore

@@ -1,3 +1,8 @@
+# Sublime editor files:
+ampersand.sublime-project
+ampersand.sublime-workspace
+
+# Cabal files
 cabal.sandbox.config
 .cabal-sandbox
 .dist-buildwrapper

Conjuncts.docadl → AmpersandData/FormalAmpersand/Conjuncts.docadl

@@ -43,4 +43,4 @@ PURPOSE RULE Conjuncts4
 {+For the purpose of keeping track of things, every conjunct gets a name.
 That is the same name as the name of the rule from which the conjunct is derived.
 -}
-ENDCONTEXT
+ENDCONTEXT

README.md

@@ -14,6 +14,4 @@ Check out the [release notes](https://github.com/AmpersandTarski/Ampersand/blob/
 
 The best place to look at if you are new to Ampersand, and you want to install the software, is at our [documentation](http://ampersandtarski.gitbooks.io/documentation/). Anyone can add comments if you read the documentation online. Please do so if there is anything you miss in the documentation. 
 
-There is an [old wiki](http://wiki.tarski.nl) too, where information can be found. 
-
 There is also some [documentation for the developers of ampersand](http://ampersandtarski.gitbooks.io/the-tools-we-use-for-ampersand/). 

ReleaseNotes.md

@@ -1,6 +1,9 @@
 # Release notes of Ampersand
 
-## Unreleased changes
+## v3.9.4 (16 march 2018)
+
+* Better performance of the generator, due to using Haskell's sets rather than lists.
+* [Issue #758](https://github.com/AmpersandTarski/Ampersand/issues/758) Fixed a bug that could cause a runtime error in edgecases
 
 ## v3.9.3 (16 february 2018)
 

ampersand.cabal

@@ -1,5 +1,5 @@
 name:           ampersand
-version:        3.9.3
+version:        3.9.4
 author:         Stef Joosten
 maintainer:     stef.joosten@ou.nl
 synopsis:       Toolsuite for automated design of business processes.
@@ -82,7 +82,6 @@ library
                      Ampersand.Basics,
                      Ampersand.Basics.Auxiliaries,
                      Ampersand.Basics.BuildInfo_Generated,
-                     Ampersand.Basics.Collection,
                      Ampersand.Basics.Exit,
                      Ampersand.Basics.Languages,
                      Ampersand.Basics.PandocExtended,

appveyor.yml

@@ -42,10 +42,11 @@ build_script:
 - stack --local-bin-path . install ampersand
 
 # Run weeder, to check that there are no weeds (see https://github.com/ndmitchell/weeder )
-- stack install weeder --resolver=nightly
-- weeder --version
-- weeder . --build
-# - ps: Invoke-Command ([Scriptblock]::Create((Invoke-WebRequest 'https://raw.githubusercontent.com/ndmitchell/weeder/master/misc/appveyor.ps1').Content)) -ArgumentList @('.')
+# - stack install weeder --resolver=nightly
+# - weeder --version
+# - weeder . --build
+- ps: Invoke-Command ([Scriptblock]::Create((Invoke-WebRequest 'https://raw.githubusercontent.com/ndmitchell/weeder/master/misc/appveyor.ps1').Content)) -ArgumentList @('--version')
+- ps: Invoke-Command ([Scriptblock]::Create((Invoke-WebRequest 'https://raw.githubusercontent.com/ndmitchell/weeder/master/misc/appveyor.ps1').Content)) -ArgumentList @('. --build')
 
 # Set a magical environment variable
 - cmd: for /f %%i in ('stack exec -- ampersand -v') do set AMPERSAND_VERSION=%%i

src/Ampersand/ADL1/Disambiguate.hs

@@ -5,7 +5,7 @@ module Ampersand.ADL1.Disambiguate
    , DisambPrim(..)
    , pCpt2aCpt
    ) where
-import           Ampersand.Basics hiding (uni,isc)
+import           Ampersand.Basics
 import           Ampersand.Core.ParseTree
 import           Ampersand.Core.AbstractSyntaxTree
 import qualified Data.Set as Set
@@ -224,10 +224,10 @@ performUpdate ((t,unkn), Cnstr srcs' tgts')
  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 )
+   possibleConcs = (mustBeSrc `Set.intersection` mustBeTgt) `orWhenEmptyS`
+                   (mustBeSrc `Set.union` mustBeTgt) `orWhenEmptyS`
+                   (mayBeSrc  `Set.intersection` mayBeTgt ) `orWhenEmptyS`
+                   (mayBeSrc  `Set.union` mayBeTgt )
    findMatch' (a,b) = findMatch (Set.toList a,Set.toList b)
    findMatch ([],[]) _ = []
    findMatch ([],tgts) lst
@@ -246,8 +246,6 @@ performUpdate ((t,unkn), Cnstr srcs' tgts')
    determineBySize _   [a] = impure (t,Known a)
    determineBySize err lst = fmap ((,) t) (err lst)
    impure x = Change x False
-   isc = Set.intersection
-   uni = Set.union
 
 orWhenEmpty :: [a] -> [a] -> [a]
 orWhenEmpty a b = if null a then b else a

src/Ampersand/ADL1/Expression.hs

@@ -1,13 +1,15 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 module Ampersand.ADL1.Expression (
-                       subst
+                       Expressions
+                      ,subst
                       ,primitives, subExpressions, isMp1, isEEps, isEDcD
                       ,isPos,isNeg, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc, notCpl, isCpl
                       ,exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list
                       ,insParentheses)
 where
-import Ampersand.Basics
-import Ampersand.Core.AbstractSyntaxTree
+import           Ampersand.Basics
+import           Ampersand.Core.AbstractSyntaxTree
+import qualified Data.Set as Set
 
 -- | subst is used to replace each occurrence of a relation
 --   with an expression. The parameter expr will therefore be applied to an
@@ -38,55 +40,55 @@ subst (decl,expr) = subs
        subs e@EDcV{}     = e
        subs e@EMp1{}     = e
 
-
-primitives :: Expression -> [Expression]
+type Expressions = Set.Set Expression
+primitives :: Expression -> Expressions
 primitives expr =
   case expr of
-    (EEqu (l,r)) -> primitives l `uni` primitives r
-    (EInc (l,r)) -> primitives l `uni` primitives r
-    (EIsc (l,r)) -> primitives l `uni` primitives r
-    (EUni (l,r)) -> primitives l `uni` primitives r
-    (EDif (l,r)) -> primitives l `uni` primitives r
-    (ELrs (l,r)) -> primitives l `uni` primitives r
-    (ERrs (l,r)) -> primitives l `uni` primitives r
-    (EDia (l,r)) -> primitives l `uni` primitives r
-    (ECps (l,r)) -> primitives l `uni` primitives r
-    (ERad (l,r)) -> primitives l `uni` primitives r
-    (EPrd (l,r)) -> primitives l `uni` primitives r
+    (EEqu (l,r)) -> primitives l `Set.union` primitives r
+    (EInc (l,r)) -> primitives l `Set.union` primitives r
+    (EIsc (l,r)) -> primitives l `Set.union` primitives r
+    (EUni (l,r)) -> primitives l `Set.union` primitives r
+    (EDif (l,r)) -> primitives l `Set.union` primitives r
+    (ELrs (l,r)) -> primitives l `Set.union` primitives r
+    (ERrs (l,r)) -> primitives l `Set.union` primitives r
+    (EDia (l,r)) -> primitives l `Set.union` primitives r
+    (ECps (l,r)) -> primitives l `Set.union` primitives r
+    (ERad (l,r)) -> primitives l `Set.union` primitives r
+    (EPrd (l,r)) -> primitives l `Set.union` 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]
-subExpressions :: Expression -> [Expression]
+    EDcD{}       -> Set.singleton expr
+    EDcI{}       -> Set.singleton expr
+    EEps{}       -> Set.empty  -- Since EEps is inserted for typing reasons only, we do not consider it a primitive..
+    EDcV{}       -> Set.singleton expr
+    EMp1{}       -> Set.singleton expr
+subExpressions :: Expression -> Expressions
 subExpressions expr = 
   case expr of
-    (EEqu (l,r)) -> [expr] `uni` subExpressions l `uni` subExpressions r
-    (EInc (l,r)) -> [expr] `uni` subExpressions l `uni` subExpressions r
-    (EIsc (l,r)) -> [expr] `uni` subExpressions l `uni` subExpressions r
-    (EUni (l,r)) -> [expr] `uni` subExpressions l `uni` subExpressions r
-    (EDif (l,r)) -> [expr] `uni` subExpressions l `uni` subExpressions r
-    (ELrs (l,r)) -> [expr] `uni` subExpressions l `uni` subExpressions r
-    (ERrs (l,r)) -> [expr] `uni` subExpressions l `uni` subExpressions r
-    (EDia (l,r)) -> [expr] `uni` subExpressions l `uni` subExpressions r
-    (ECps (l,r)) -> [expr] `uni` subExpressions l `uni` subExpressions r
-    (ERad (l,r)) -> [expr] `uni` subExpressions l `uni` subExpressions r
-    (EPrd (l,r)) -> [expr] `uni` subExpressions l `uni` subExpressions r
-    (EKl0 e)     -> [expr] `uni` subExpressions e
-    (EKl1 e)     -> [expr] `uni` subExpressions e
-    (EFlp e)     -> [expr] `uni` subExpressions e
-    (ECpl e)     -> [expr] `uni` subExpressions e
-    (EBrk e)     -> [expr] `uni` subExpressions e
-    EDcD{}       -> [expr]
-    EDcI{}       -> [expr]
-    EEps{}       -> [expr]
-    EDcV{}       -> [expr]
-    EMp1{}       -> [expr]
+    (EEqu (l,r)) -> Set.singleton expr `Set.union` subExpressions l `Set.union` subExpressions r
+    (EInc (l,r)) -> Set.singleton expr `Set.union` subExpressions l `Set.union` subExpressions r
+    (EIsc (l,r)) -> Set.singleton expr `Set.union` subExpressions l `Set.union` subExpressions r
+    (EUni (l,r)) -> Set.singleton expr `Set.union` subExpressions l `Set.union` subExpressions r
+    (EDif (l,r)) -> Set.singleton expr `Set.union` subExpressions l `Set.union` subExpressions r
+    (ELrs (l,r)) -> Set.singleton expr `Set.union` subExpressions l `Set.union` subExpressions r
+    (ERrs (l,r)) -> Set.singleton expr `Set.union` subExpressions l `Set.union` subExpressions r
+    (EDia (l,r)) -> Set.singleton expr `Set.union` subExpressions l `Set.union` subExpressions r
+    (ECps (l,r)) -> Set.singleton expr `Set.union` subExpressions l `Set.union` subExpressions r
+    (ERad (l,r)) -> Set.singleton expr `Set.union` subExpressions l `Set.union` subExpressions r
+    (EPrd (l,r)) -> Set.singleton expr `Set.union` subExpressions l `Set.union` subExpressions r
+    (EKl0 e)     -> Set.singleton expr `Set.union` subExpressions e
+    (EKl1 e)     -> Set.singleton expr `Set.union` subExpressions e
+    (EFlp e)     -> Set.singleton expr `Set.union` subExpressions e
+    (ECpl e)     -> Set.singleton expr `Set.union` subExpressions e
+    (EBrk e)     -> Set.singleton expr `Set.union` subExpressions e
+    EDcD{}       -> Set.singleton expr
+    EDcI{}       -> Set.singleton expr
+    EEps{}       -> Set.singleton expr
+    EDcV{}       -> Set.singleton expr
+    EMp1{}       -> Set.singleton 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.