Merge pull request #501 from AmpersandTarski/development

Release 3.6.1

.codeclimate.yml

@@ -0,0 +1,7 @@
+engines:
+ hlint:
+    enabled: true
+
+  ratings:
+    paths:
+      - "**.hs"

.gitignore

@@ -1,7 +1,7 @@
 cabal.sandbox.config
 .cabal-sandbox
 .dist-buildwrapper
-dist
+/dist
 .idea
 
 StaticFiles_Generated.hs
@@ -25,5 +25,5 @@ miscellaneous/AmpersandBackup.jgfns
 .settings/org.eclipse.php.core.prefs
 /.stack-work
 static/zwolle/lib/
-static/zwolle/app/bower_components/
+# static/zwolle/app/bower_components/
 static/zwolle/app/node_modules/

README.md

@@ -2,11 +2,14 @@
 
 [![Build Status](https://travis-ci.org/AmpersandTarski/Ampersand.svg?branch=master)](https://travis-ci.org/AmpersandTarski/Ampersand)
 [![Build status](https://ci.appveyor.com/api/projects/status/ai0pwvb7corwkjjm?svg=true)](https://ci.appveyor.com/project/hanjoosten/ampersand)
-[![Release](https://img.shields.io/github/release/AmpersandTarski/Ampersand.svg)](https://github.com/AmpersandTarski/Ampersand/releases)
+[![Latest Release](https://img.shields.io/github/release/AmpersandTarski/Ampersand.svg)](https://github.com/AmpersandTarski/Ampersand/releases/latest)
 
 ## Recent activity 
 [![Throughput Graph](https://graphs.waffle.io/AmpersandTarski/Ampersand/throughput.svg)](https://waffle.io/AmpersandTarski/Ampersand/metrics)
 
+## Releases
+Check out the [release notes](https://github.com/AmpersandTarski/Ampersand/blob/development/ReleaseNotes.md) and [![all Releases](https://img.shields.io/github/release/AmpersandTarski/Ampersand.svg)](https://github.com/AmpersandTarski/Ampersand/releases)
+
 ## Documentation
 
 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. 

ReleaseNotes.md

@@ -1,15 +1,28 @@
 # Release notes of Ampersand
 
+## v3.6.1 (5 august 2016)
+  * [Issue #488](https://github.com/AmpersandTarski/Ampersand/issues/488) Performance enhancement: Added indexes on table columns when possible
+  * [Issue #486](https://github.com/AmpersandTarski/Ampersand/issues/486) Performance enhancement: Removed DISTINCT in subqueries
+  * [Issue #459](https://github.com/AmpersandTarski/Ampersand/issues/459) fix for underscores in Concept name
+  * [Issue #489](https://github.com/AmpersandTarski/Ampersand/issues/489) Implemented markdown for rule violation messages in frontend
+  * [Issue #412](https://github.com/AmpersandTarski/Ampersand/issues/412) Partial fix for removing rows from COLS template 
+  * [Issue #373](https://github.com/AmpersandTarski/Ampersand/issues/373) Fix breadcrumb
+  * ExecEngine extension: improved logging for debugging
+  * Added new reporting functionality for backend framework
+  * DB performance: less queries because 'I[Concept]'-expression is not queried anymore
+  * Minor backend fixes
+  * Fix issues regarding CRUD specifications: missing interfaces in navbar +menu, missing crudR check in templates, return content after create
+
 ## v3.6.0 (8 july 2016)
   * [Issue #406](https://github.com/AmpersandTarski/Ampersand/issues/406) Minor changes on syntax of INTERFACE statement. 
   * [Issue #438](https://github.com/AmpersandTarski/Ampersand/issues/438) New switch: --include
   * [Issue #438](https://github.com/AmpersandTarski/Ampersand/issues/438) Enhancement: Introduction of a configuration file. A sample configuration file is generated when you use the switch --sampleConfigFile. To use a config file, use the switch --config=MyConfig.yaml
   * [Issue #468](https://github.com/AmpersandTarski/Ampersand/issues/468) Enhancement: default configuration file (when it exists)
-  * Enhancement: From now on, all text values read from .xlsx files are trimmed (leading and trailing spaces are removed), unless the switch --do-not-trim-cellvalues is given. [Issue #414](https://github.com/AmpersandTarski/Ampersand/issues/414)
+  * [Issue #414](https://github.com/AmpersandTarski/Ampersand/issues/414) Enhancement: From now on, all text values read from .xlsx files are trimmed (leading and trailing spaces are removed), unless the switch --do-not-trim-cellvalues is given. 
   * More automation on releasing Ampersand.
   * Frontend: Options in frontend navbar now can be defined for certain roles only (e.g. the installer and excelimporter).
   * [Issue #103](https://github.com/AmpersandTarski/Ampersand/issues/103) Fix overlap by multiple rows in navbar
-  * [Issue #423] Database is automatically installed when it does not exists yet (first time use)
+  * [Issue #423](https://github.com/AmpersandTarski/Ampersand/issues/423) Database is automatically installed when it does not exists yet (first time use)
 
 ## v3.5.2 (10 juni 2016)
   * Work on meatgrinder (still experimental!)

ampersand.cabal

@@ -1,5 +1,5 @@
 name:           ampersand
-version:        3.6.0
+version:        3.6.1
 author:         Stef Joosten
 maintainer:     [email protected]
 synopsis:       Toolsuite for automated design of business processes.

appveyor.yml

@@ -7,6 +7,9 @@
 # Disable the standard build process which would use MSBuild:
 build: off
 
+# version format
+version: build.{build}-{branch}
+
 cache:
 - "c:\\sr" # stack root, short paths == fewer problems
 clone_folder: "c:\\stack"
@@ -38,6 +41,7 @@ build_script:
 # mark the file(s) as an artifact; this means AppVeyor will hang on to it after the build completes:
 artifacts:
 - path: ampersand.exe
+  name: Windows binary
 
 # Auto-deploy
 # specify that, for each build that completes, AppVeyor should push
@@ -51,6 +55,7 @@ deploy:
     release: '$(AMPERSAND_VERSION)'
     auth_token:
       secure: B9wxH2Me3jIbEn9xlvIY9SEWdELRgKMtEZeQZmJQm5wMGjp4YF4wQmAHCy3ofTJG
-    artifact: ampersand.exe
-    on:
-      branch: master
+    artifact: Windows binary
+
+
+

src/Database/Design/Ampersand/ADL1/Disambiguate.hs

@@ -1,24 +1,11 @@
-{-# OPTIONS_GHC -Wall -Werror #-}
+{-# OPTIONS_GHC -Wall #-}
 module Database.Design.Ampersand.ADL1.Disambiguate(disambiguate, orWhenEmpty, DisambPrim(..),pCpt2aCpt) where
 import Database.Design.Ampersand.Core.ParseTree
 import Database.Design.Ampersand.Core.AbstractSyntaxTree
-import Database.Design.Ampersand.Basics (fatal)
+--import Database.Design.Ampersand.Basics (fatal)
 --import Control.Applicative
---import Data.Traversable
 import qualified Data.Set as Set
 
-findConcept :: String -> A_Concept
--- SJC: ONE should be tokenized, so it cannot occur as a string
--- especially because we require that concepts are identifiable by their name
--- hence if this line would change the semantics, we have either
--- (1) made a programming error in the call of findConcept (in which case you should call findConceptOrONE instead)
--- (2) made an error in the tokenizer/parser
-findConcept "ONE" = fatal 200 "ONE is not a valid name for a concept"
-findConcept x =
-   PlainConcept { cptnm = x
-                }
-
-
 -- this is *only* used internally!
 data D_Concept
  = MustBe A_Concept
@@ -264,7 +251,7 @@ orWhenEmpty a b = if (null a) then b else a
 pCpt2aCpt :: P_Concept -> A_Concept
 pCpt2aCpt pc
     = case pc of
-        PCpt{} -> findConcept (p_cptnm pc)
+        PCpt{} -> makeConcept (p_cptnm pc)
         P_Singleton -> ONE
 
 data Change a = Change a Bool

src/Database/Design/Ampersand/ADL1/P2A_Converters.hs

@@ -24,6 +24,8 @@ import Data.List as Lst
 import Data.Char(toUpper,toLower)
 import Data.Either
 import GHC.Stack
+import Data.Hashable
+import Data.Text (pack)
 import Control.Arrow(first)
 
 data Type = UserConcept String
@@ -41,7 +43,7 @@ instance Named Type where
 
 typeOrConcept :: Type -> Either A_Concept (Maybe TType)
 typeOrConcept (BuiltIn TypeOfOne)  = Left  ONE
-typeOrConcept (UserConcept s)      = Left$ PlainConcept s
+typeOrConcept (UserConcept s)      = Left$ makeConcept s
 typeOrConcept (BuiltIn x)          = Right (Just x)
 typeOrConcept RepresentSeparator = Right Nothing
 
@@ -155,7 +157,7 @@ checkOtherAtomsInSessionConcept ctx = case [mkOtherAtomInSessionError atom
                                         [] -> return ()
                                         errs -> Errors errs
         where isPermittedSessionValue :: AAtomValue -> Bool
-              isPermittedSessionValue (AAVString _ str) = str == "_SESSION"
+              isPermittedSessionValue v@AAVString{} = aavstr v == "_SESSION"
               isPermittedSessionValue _                 = False
 
 pSign2aSign :: P_Sign -> Signature
@@ -245,8 +247,7 @@ pCtx2aCtx opts
                      , ctxpats = pats
                      , ctxrs = rules
                      , ctxds = map fst declsAndPops
-                     , ctxpopus = Lst.nub (udpops
-                                     ++map snd declsAndPops)
+                     , ctxpopus = Set.toList (Set.union (Set.fromList udpops) (Set.fromList (map snd declsAndPops)))
                      , ctxcds = allConceptDefs
                      , ctxks = identdefs
                      , ctxrrules = allRoleRules
@@ -310,7 +311,7 @@ pCtx2aCtx opts
               reprTrios :: [(A_Concept,TType,Origin)]
               reprTrios = nub $ concatMap toReprs reprs
                 where toReprs :: Representation -> [(A_Concept,TType,Origin)]
-                      toReprs r = [ (castConcept str,reprdom r,reprpos r) | str <- reprcpts r]
+                      toReprs r = [ (makeConcept str,reprdom r,reprpos r) | str <- reprcpts r]
               conceptsOfGroups :: [A_Concept]
               conceptsOfGroups = nub (concat groups)
               conceptsOfReprs :: [A_Concept]
@@ -433,7 +434,7 @@ pCtx2aCtx opts
       -> P_Declaration -> Guarded (Declaration,Population)
     pDecl2aDecl patNm contextInfo defLanguage defFormat pd
      = let (prL:prM:prR:_) = dec_pragma pd ++ ["", "", ""]
-           dcl = Sgn { decnm   = dec_nm pd
+           dcl = Sgn { decnm   = pack (dec_nm pd)
                      , decsgn  = decSign
                      , decprps = dec_prps pd
                      , decprps_calc = Nothing  --decprps_calc in an A_Context are still the user-defined only. prps are calculated in adl2fspec.
@@ -445,6 +446,7 @@ pCtx2aCtx opts
                      , decusr  = True
                      , decpat  = patNm
                      , decplug = dec_plug pd
+                     , dech    = hash (dec_nm pd) `hashWithSalt` decSign
                      }
        in checkEndoProps >> 
           (\aps -> (dcl,ARelPopu { popdcl = dcl
@@ -487,9 +489,6 @@ pCtx2aCtx opts
        where
          leastConcepts = findExact genLattice (Atom (aConcToType c) `Meet` Atom (aConcToType str))
 
-    castConcept :: String -> A_Concept
-    castConcept "ONE" = ONE
-    castConcept x     = PlainConcept { cptnm = x }
     userConcept :: String -> Type
     userConcept "ONE" = BuiltIn TypeOfOne
     userConcept x     = UserConcept x
@@ -499,7 +498,7 @@ pCtx2aCtx opts
      case pop of
        P_RelPopu{p_nmdr = nmdr, p_popps=aps, p_src = src, p_tgt = tgt}
          -> do dcl <- case p_mbSign nmdr of
-                        Nothing -> findDeclLooselyTyped declMap pop (name nmdr) (castConcept <$> src) (castConcept <$> tgt)
+                        Nothing -> findDeclLooselyTyped declMap pop (name nmdr) (makeConcept <$> src) (makeConcept <$> tgt)
                         _ -> namedRel2Decl declMap nmdr
 
                aps' <- traverse (pAtomPair2aAtomPair contextInfo dcl) aps
@@ -511,7 +510,7 @@ pCtx2aCtx opts
                                , poptgt = fromMaybe (target dcl) tgt'
                                }
        P_CptPopu{}
-         -> let cpt = castConcept (p_cnme pop) in  
+         -> let cpt = makeConcept (p_cnme pop) in  
             (\vals
               -> ACptPopu { popcpt = cpt
                           , popas  = vals

src/Database/Design/Ampersand/Basics/Auxiliaries.hs

@@ -27,9 +27,9 @@ eqClass f (x:xs) = (x:[e |e<-xs, f x e]) : eqClass f [e |e<-xs, not (f x e)]
 --    'eqCl name persons' produces a list,in which each element is a list of persons with the same name.
 -- Example> eqCl (=='s') "Mississippi" = "ssss"
 
-eqCl :: Eq b => (a -> b) -> [a] -> [[a]]
+eqCl :: Ord 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]
+eqCl f lst = Map.elems (Map.fromListWith (++) [(f e,[e]) | e <- lst])
 
 -- | 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)
@@ -42,12 +42,19 @@ getCycles edges =
 
 
 -- |  Warshall's transitive closure algorithm
-transClosureMap :: (Eq a, Ord a) => Map a [a] -> Map a [a]
-transClosureMap xs
+transClosureMap' :: (Eq a, Ord a) => Map a [a] -> Map a [a]
+transClosureMap' xs
   = foldl f xs (Map.keys xs `intersect` nub (concat (Map.elems xs)))
     where
      f :: (Eq a, Ord a) => Map a [a] -> a -> Map a [a]   -- The type is given for documentation purposes only
      f q x = Map.unionWith union q (Map.fromListWith union [(a, q Map.! x) | (a, bs) <- Map.assocs q, x `elem` bs])
+-- |  Warshall's transitive closure algorithm
+transClosureMap :: (Eq a, Ord a) => Map a (Set a) -> Map a (Set a)
+transClosureMap xs
+  = foldl f xs (Map.keysSet xs `Set.intersection` (mconcat (Map.elems xs)))
+    where
+     f :: (Eq a, Ord a) => Map a (Set a) -> a -> Map a (Set a)
+     f q x = Map.unionWith Set.union q (Map.fromListWith Set.union [(a, q Map.! x) | (a, bs) <- Map.assocs q, x `elem` bs])
 
 -- The following function can be used to determine how much of a set of alternative expression is already determined
 -- | The 'combinations' function returns all possible combinations of lists of list.

src/Database/Design/Ampersand/Basics/Collection.hs

@@ -6,22 +6,23 @@ module Database.Design.Ampersand.Basics.Collection
                 ,empty
                 ,elems)
   )where
-   ----------------------------------------------
-   ---- Collection of type a --------------------
-   ----------------------------------------------
-   infixl 5  >-
+import qualified Data.Set as Set
+----------------------------------------------
+---- 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]
+class Collection a where      
+ eleM :: Eq b => b -> a b -> Bool
+ uni, isc :: Ord b => a b -> a b -> a b
+ (>-) :: Ord 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
+instance Collection [] where -- TODO Vervangen door 'Collection Set.Set' en fouten één voor één oplossen
+ eleM         = elem
+ xs `uni` ys  = xs++(ys>-xs)
+ xs `isc` ys  = [y | y<-ys, y `Set.member` Set.fromList xs]
+ xs >- ys     = [x | x<-xs, x `Set.notMember` Set.fromList ys]
+ empty        = []
+ elems        = id

src/Database/Design/Ampersand/Basics/Unique.hs

@@ -11,7 +11,7 @@ where
 import Data.Typeable
 import Data.List
 import Data.Char
-import Database.Design.Ampersand.Basics.Version
+import Database.Design.Ampersand.Basics.Version(fatal)
 
 -- | anything could have some label, can't it?
 class Named a where
@@ -42,11 +42,11 @@ class (Typeable e, Eq e) => Unique e where
 -- | this is the implementation of the abstract data type. It mustn't be exported
 data UniqueObj a = 
        UniqueObj { theThing :: a
-                 , theShow  :: (a -> String)
+                 , theShow  :: a -> String
                  } deriving (Typeable)
 
 instance Unique a => Unique [a] where
-   showUnique [] = fatal 74 $ "empty list is not unique"
+   showUnique [] = fatal 74 "empty list is not unique"
    showUnique xs = "["++intercalate ", " (map showUnique xs)++"]"
 
 instance Unique Bool where

src/Database/Design/Ampersand/Classes/ConceptStructure.hs

@@ -50,7 +50,7 @@ instance ConceptStructure a => ConceptStructure [a] where
   expressionsIn = foldr ((uni) . expressionsIn) []
 
 instance ConceptStructure A_Context where
-  concs ctx = foldr uni [ONE, PlainConcept "SESSION"]  -- ONE and [SESSION] are allways in any context. (see https://github.com/AmpersandTarski/ampersand/issues/70)
+  concs ctx = foldr uni [ONE, makeConcept "SESSION"]  -- ONE and [SESSION] are allways in any context. (see https://github.com/AmpersandTarski/ampersand/issues/70)
               [ (concs.ctxpats) ctx
               , (concs.ctxrs) ctx
               , (concs.ctxds) ctx
@@ -106,9 +106,7 @@ instance ConceptStructure A_Concept where
   expressionsIn _ = []
 
 instance ConceptStructure ConceptDef where
-  concs        cd = [PlainConcept { cptnm = name cd
-                                  }
-                    ]
+  concs        cd = [makeConcept (name cd)]
   expressionsIn _ = []
 
 instance ConceptStructure Signature where

src/Database/Design/Ampersand/Components.hs

@@ -21,6 +21,7 @@ import System.FilePath
 import Data.Time.Clock.POSIX
 import qualified Data.ByteString.Lazy as L
 import Data.List
+import qualified Data.Text.IO as Text
 import Data.Function (on)
 
 import System.Exit
@@ -80,7 +81,7 @@ doGenHaskell fSpec =
 doGenSQLdump :: FSpec -> IO()
 doGenSQLdump fSpec =
  do { verboseLn (getOpts fSpec) $ "Generating SQL queries dumpfile for "++name fSpec
-    ; writeFile outputFile (dumpSQLqueries fSpec)
+    ; Text.writeFile outputFile (dumpSQLqueries fSpec)
     ; verboseLn (getOpts fSpec) $ "SQL queries dumpfile written into " ++ outputFile ++ "."
     }
  where outputFile = combine (dirOutput (getOpts fSpec)) $ replaceExtension (baseName (getOpts fSpec)) ".sqlDump"