Merge pull request #1012 from AmpersandTarski/development

Release 3.17.4

.dockerignore

@@ -0,0 +1,2 @@
+.stack-work
+*.lock

Dockerfile

@@ -0,0 +1,39 @@
+FROM haskell:8.6.5 AS buildstage
+# The purpose of this docker file is to produce a latest Ampersand-compiler in the form of a docker image.
+# Purpose: a light-weight container can copy ampersand executables from /root/.local/bin, ignoring the build-stuff such as source code and setup-work
+
+# The Haskell version number must be consistent with ./stack.yaml to ensure successful compilation.
+
+# build from the Ampersand source code directory
+WORKDIR /Ampersand/
+
+# clone the ampersand source files ('git clone' requires the directory to be empty)
+RUN git clone https://github.com/AmpersandTarski/Ampersand/ .
+
+# get Ampersand sources in the desired version
+RUN git checkout feature/Archimate3
+
+# Or alternatively, just copy your Ampersand working directory (i.e. your own clone of Ampersand) into the build
+# COPY . .
+
+# set up Haskell stack; downloads approx 177MB
+# Don't worry about the correct version of ghc. It is specified in stack.yaml
+# RUN stack setup
+
+# installs Ampersand executables in /root/.local/bin
+RUN stack install
+
+# show the results of the build stage
+RUN ls -al /root/.local/bin
+
+FROM ubuntu
+
+VOLUME ["/scripts"]
+
+COPY --from=buildstage /root/.local/bin/ampersand /bin/
+
+WORKDIR /scripts
+
+ENTRYPOINT ["/bin/ampersand"]
+
+CMD ["--verbose"]

ReleaseNotes.md

@@ -1,5 +1,9 @@
 # Release notes of Ampersand
 
+## v3.17.4 (13 september 2019)
+
+* Upgrade to [LTS Haskell 14.5 (ghc-8.6.5)](https://www.stackage.org/lts-14.5)
+
 ## v3.17.3 (2 august 2019)
 
 * Allow interface roles to be editable. Accessible interfaces for a given role are now queries from database instead of generated json files (requires update of prototype framework)

package.yaml

@@ -1,5 +1,5 @@
 name:           ampersand
-version:        3.17.3
+version:        3.17.4
 author:         Stef Joosten
 maintainer:     stef.joosten@ou.nl
 synopsis:       Toolsuite for automated design of enterprise information systems.
@@ -35,7 +35,7 @@ default-extensions:
 dependencies:
       - aeson == 1.4.*
       - aeson-pretty == 0.8.*
-      - ansi-terminal == 0.8.*
+      - ansi-terminal == 0.9.*
       - base == 4.12.*
       - bytestring == 0.10.*
       - conduit == 1.3.*
@@ -51,12 +51,12 @@ dependencies:
       - http-conduit == 2.3.*
       - lens == 4.17.*
       - mtl == 2.2.*
-      - pandoc == 2.5
+      - pandoc == 2.7.*
       - pandoc-crossref == 0.3.4.0
       - pandoc-types == 1.17.*
       - parsec == 3.1.*
       - process == 1.6.*
-      - QuickCheck == 2.12.6.1
+      - QuickCheck == 2.13.*
       - rio == 0.1.*
       - simple-sql-parser == 0.4.4
       - split == 0.2.*

src/Ampersand/ADL1/Disambiguate.hs

@@ -61,12 +61,12 @@ class Traversable d => Disambiguatable d where
                 (TermPrim -> (TermPrim, DisambPrim)) -- disambiguation function
                 -> d TermPrim -- object to be disambiguated
                 -> d (TermPrim, DisambPrim) -- disambiguated object
-  disambiguate termPrimDisAmb x = fixpoint disambiguationStep (Change (fmap termPrimDisAmb x) False)
+  disambiguate termPrimDisAmb x = fixpoint disambiguationStep (Change (fmap termPrimDisAmb x))
     where
      fixpoint :: (a -> Change a) -- function for computing a fixpoint
               -> Change a -> a
-     fixpoint _ (Change a True)  = a
-     fixpoint f (Change a False) = fixpoint f (f a)
+     fixpoint _ (Stable a)  = a
+     fixpoint f (Change a) = fixpoint f (f a)
 
   disambiguationStep :: d (TermPrim, DisambPrim) -> Change (d (TermPrim, DisambPrim))
   disambiguationStep thing = traverse performUpdate withInfo
@@ -263,7 +263,7 @@ performUpdate ((t,unkn), Cnstr srcs' tgts')
    orWhenEmptyS a b = if Set.null a then b else a
    determineBySize _   [a] = impure (t,Known a)
    determineBySize err lst = fmap ((,) t) (err lst)
-   impure x = Change x False
+   impure x = Change x
 
 orWhenEmpty :: [a] -> [a] -> [a]
 orWhenEmpty a b = if null a then b else a
@@ -274,9 +274,15 @@ pCpt2aCpt pc
         PCpt{} -> makeConcept (p_cptnm pc)
         P_Singleton -> ONE
 
-data Change a = Change a Bool
+data Change a
+  = Stable a
+  | Change a
 instance Functor Change where
- fmap f (Change a b) = Change (f a) b
+  fmap f (Change a) = Change (f a)
+  fmap f (Stable a) = Stable (f a)
 instance Applicative Change where
- (<*>) (Change f b) (Change a b2) = Change (f a) (b && b2)
- pure a = Change a True
+  (<*>) (Stable f) (Stable a) = Stable (f a)
+  (<*>) (Change f) (Stable a) = Change (f a)
+  (<*>) (Change f) (Change a) = Change (f a)
+  (<*>) (Stable f) (Change a) = Change (f a)
+  pure a = Stable a

src/Ampersand/Basics/Prelude.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 module Ampersand.Basics.Prelude
-  ( module Prelude
-  , module RIO
+  ( module RIO
   , say, sayLn
   , sayWhenLoud, sayWhenLoudLn
   , writeFile
@@ -10,9 +9,10 @@ module Ampersand.Basics.Prelude
   , openTempFile
   , HasHandle(..)
   , HasVerbosity(..), Verbosity (..)
+  , reads, getChar
   )where
 import Prelude (reads,getChar) -- Needs to be fixed later. See https://haskell.fpcomplete.com/library/rio we'll explain why we need this in logging
-import RIO
+import RIO hiding (zipWith,exitWith)
 import System.IO (openTempFile,hPutStr,hPutStrLn, stderr)
 import qualified RIO.Text as T
 

src/Ampersand/Components.hs

@@ -19,9 +19,8 @@ import           Ampersand.Output
 import           Ampersand.Prototype.GenFrontend (doGenFrontend)
 import           Ampersand.Prototype.ValidateSQL (validateRulesSQL)
 import qualified RIO.ByteString.Lazy as BL
-import           Data.Function (on)
 import qualified RIO.List as L
-import qualified Data.List.NonEmpty as NEL
+--import qualified Data.List.NonEmpty as NEL
 import qualified RIO.Set as Set
 import qualified RIO.Text as T
 import           Data.Maybe (isJust, fromJust)
@@ -34,9 +33,11 @@ import           Text.Pandoc.Builder
 --    takes the FSpec as its input, and spits out everything the user requested.
 generateAmpersandOutput :: Options -> MultiFSpecs -> RIO App ()
 generateAmpersandOutput opts@Options{..} multi = do
-    sayWhenLoudLn "Checking for rule violations..."
-    if dataAnalysis then sayWhenLoudLn "Not checking for rule violations because of data analysis." else reportInvViolations violationsOfInvariants
-    reportSignals (initialConjunctSignals fSpec)
+    if dataAnalysis
+      then sayWhenLoudLn "Not checking for rule violations because of data analysis."
+      else if allowInvariantViolations
+      then sayWhenLoudLn "Not checking for rule violations because option ignore-invariant-violations."
+      else sayWhenLoudLn "Checking for rule violations..." >> reportInvViolations violationsOfInvariants
     liftIO $ createDirectoryIfMissing True dirOutput
     sequence_ . map snd . filter fst $ conditionalActions
   where 
@@ -189,29 +190,16 @@ generateAmpersandOutput opts@Options{..} multi = do
        -- TODO: this is a nice use case for outputting warnings
        sayLn "There are invariant violations that are ignored. Use --verbose to output the violations"
      else
-       let ruleNamesAndViolStrings = [ (name r, showprs p) | (r,p) <- viols ]
-       in  sayLn $ 
-                  L.intercalate "\n"
-                      [ "Violations of rule "++show r++":\n"++ concatMap (\(_,p) -> "- "++ p ++"\n") rps
-                      | rps@((r,_):_) <- L.groupBy (on (==) fst) $ L.sort ruleNamesAndViolStrings
-                      ]
+       sayLn $
+       L.intercalate "\n"
+        ([ "Violations of rule "++show r++":\n"++showpairs atompairs
+         | (r,atompairs) <- viols, not (isSignal r) ] ++
+         [ "Signals for initial population: of rule "++show r++":\n"++showpairs atompairs
+         | (r,atompairs) <- viols, isSignal r, verbosity /= Silent ]
+        )
 
-   showprs :: AAtomPairs -> String
-   showprs aprs = "["++L.intercalate ", " (Set.elems $ Set.map showA aprs)++"]"
-   -- showpr :: AAtomPair -> String
-   -- showpr apr = "( "++(showVal.apLeft) apr++", "++(showVal.apRight) apr++" )"
-   reportSignals []        = sayWhenLoudLn "No signals for the initial population" 
-   reportSignals conjViols = 
-     if verbosity == Loud
-     then
-       sayWhenLoudLn $ "Signals for initial population:\n" ++ L.intercalate "\n"
-         [   "Rule(s): "++(show . map name . NEL.toList . rc_orgRules) conj
-         ++"\n  Conjunct   : " ++ showA (rc_conjunct conj)
-         ++"\n  Violations : " ++ showprs viols
-         | (conj, viols) <- conjViols
-         ]
-     else
-       sayLn "There are signals for the initial population. Use --verbose to output the violations"
+   showpairs :: AAtomPairs -> String
+   showpairs atompairs = "    [ "++ (L.intercalate "\n    , " . Set.elems . Set.map showA) atompairs++"\n    ]"
    ruleTest :: String -> RIO App ()
    ruleTest ruleName =
     case [ rule | rule <- Set.elems $ grules fSpec `Set.union` vrules fSpec, name rule == ruleName ] of

src/Ampersand/Daemon/Daemon.hs

@@ -14,7 +14,7 @@ import           Ampersand.Daemon.Daemon.Types
 import           Ampersand.Daemon.Daemon.Util
 import           Ampersand.Daemon.Wait
 import           Ampersand.Misc
-import           Data.Ord
+-- import           Data.Ord -- is redundant
 import           Data.Tuple.Extra(both)
 import qualified RIO.List as L
 import           System.Console.ANSI (hSupportsANSI,setTitle)

src/Ampersand/Input/ADL1/LexerTexts.hs

@@ -15,7 +15,7 @@ module Ampersand.Input.ADL1.LexerTexts
     , lexerUtfChar
     ) where
 
-import Ampersand.Basics
+import Ampersand.Basics hiding (Arrow)
 import Data.Maybe (fromMaybe)
 import System.IO.Unsafe(unsafePerformIO)
 

stack.yaml

@@ -1,7 +1,7 @@
 # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
 
 # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
-resolver: lts-13.16
+resolver: lts-14.5
 # resolver: nightly-2018-11-24 # temporarily no LTS. Same as pandoc-crossref.
 allow-newer: false
 # Local packages, usually specified by relative directory name
@@ -10,15 +10,12 @@ packages:
 
 # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
 extra-deps: 
-- fgl-5.7.0.1
-- graphviz-2999.20.0.3
 - pandoc-crossref-0.3.4.0
 - roman-numerals-0.5.1.5
 - simple-sql-parser-0.4.4
 - SpreadsheetML-0.1
 - wl-pprint-1.2.1
 - yaml-config-0.4.0
-- zip-archive-0.4.1@sha256:51774bdc747d20b8f23172315f9c3fdd6c11de01607e98e9890eb87fb49566d7 # can be removed when LTS >= lts-13.19
 
 # Override default flag values for local packages and extra-deps
 flags: {}