Merge pull request #1086 from AmpersandTarski/development

Release 4.0.1

.travis.yml

@@ -136,14 +136,14 @@ install:
 - |
   case "$BUILD" in
     stack)
-      ./travis_long `# guarantee that something is written to output every minute, so travis doesn't stop premature` \
+      ./travis_long `# guarantee that something is written to output every minute, so Travis doesn't stop prematurely` \
            stack build `# build is the common task which is composable.` \
                 --test `# run the tests` \
                 --copy-bins `# install executables to the path` \
-                --haddock `# create haddock documentation, thus ensuring that haddock parse rules are enforsed.` \
-                --no-terminal `# fixes bug with sticky output on travis` \
+                --haddock `# create haddock documentation, thus ensuring that haddock parse rules are enforced.` \
+                --no-terminal `# fixes bug with sticky output on Travis` \
                 $ARGS  `#` \
-                --flag ampersand:buildAll `# build all executables of ampersand`
+                --flag ampersand:buildAll `# build all executables of Ampersand`
       ;;
     cabal)
       cabal --version

README.md

@@ -1,7 +1,7 @@
 # Ampersand
 
 [![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)
+[![Build status](https://ci.appveyor.com/api/projects/status/9stn8mx3w8vsbt2r?svg=true)](https://ci.appveyor.com/project/Ampersand-Sentinel/ampersand)
 [![Latest Release](https://img.shields.io/github/release/AmpersandTarski/Ampersand.svg)](https://github.com/AmpersandTarski/Ampersand/releases/latest)
 
 ## Releases

ReleaseNotes.md

@@ -1,5 +1,11 @@
 # Release notes of Ampersand
 
+## v4.0.1 (19 june 2020)
+
+* [Issue #1026](https://github.com/AmpersandTarski/Ampersand/issues/1026) Allow PATTERNs with the same name. Meaning: all declarations from patterns with the same name are merged into one.
+* [Issue #1081](https://github.com/AmpersandTarski/Ampersand/issues/1081) Disable invariant checking for documentation.
+* [Issue #988](https://github.com/AmpersandTarski/Ampersand/issues/988) Add switch to disable warnings with `ampersand daemon` command
+
 ## v4.0.0 (23 may 2020)
 
 * Refactor Docker image for Ampersand compiler
@@ -8,9 +14,9 @@
 * [Issue #1029](https://github.com/AmpersandTarski/Ampersand/issues/1029) Fixed detection of rules with same name.
 * [Issue #1047](https://github.com/AmpersandTarski/Ampersand/issues/1047) Non-existing directory is generated automagically when required for output.
 * [Issue #999](https://github.com/AmpersandTarski/Ampersand/issues/999) Treat all concepts in a cycle in CLASSIFY statements as aliases of a single concept.
-* [Issue #1056](https://github.com/AmpersandTarski/Ampersand/issues/#1056) Bugfix in .xlsx parser
-* [Issue #1054](https://github.com/AmpersandTarski/Ampersand/issues/#1054) Ampersand daemon now also reports type errors
-* [Issue #1063](https://github.com/AmpersandTarski/Ampersand/issues/#1063) Return violations of invariants with standard check
+* [Issue #1056](https://github.com/AmpersandTarski/Ampersand/issues/1056) Bugfix in .xlsx parser
+* [Issue #1054](https://github.com/AmpersandTarski/Ampersand/issues/1054) Ampersand daemon now also reports type errors
+* [Issue #1063](https://github.com/AmpersandTarski/Ampersand/issues/1063) Return violations of invariants with standard check
 * [Issue #735](https://github.com/AmpersandTarski/Ampersand/issues/735) Upgrade to pandoc 2.9. 
 
 * Remove option --skip-composer. Relates to topic of [Archicture of Ampersand compiler](https://github.com/AmpersandTarski/Ampersand/issues/903)

package.yaml

@@ -1,13 +1,13 @@
 name:           ampersand
-version:        4.0.0
+version:        4.0.1
 author:         Stef Joosten
 maintainer:     [email protected]
 synopsis:       Toolsuite for automated design of enterprise information systems.
 description:    You can define your business processes by means of rules, written in Relation Algebra.
 homepage:       http://ampersandtarski.github.io/
 category:       Database Design
 stability:      alpha
-tested-with:    GHC == 8.6.5
+tested-with:    GHC == 8.8.3
 build-type:     Custom
 license:        GPL
 license-file:   LICENSE

src/Ampersand/ADL1/P2A_Converters.hs

@@ -243,15 +243,15 @@ pCtx2aCtx env
       }
  = do contextInfo <- g_contextInfo -- the minimal amount of data needed to transform things from P-structure to A-structure.
       let declMap = declDisambMap contextInfo
-      uniqueNames p_patterns
+  --  uniqueNames "pattern" p_patterns   -- Unclear why this restriction was in place. So I removed it
       pats        <- traverse (pPat2aPat contextInfo) p_patterns            --  The patterns defined in this context
-      uniqueNames $ p_rules <> concatMap pt_rls p_patterns
+      uniqueNames "rule" $ p_rules <> concatMap pt_rls p_patterns
       rules       <- traverse (pRul2aRul contextInfo Nothing) p_rules       --  All user defined rules in this context, but outside patterns
-      uniqueNames $ p_identdefs <> concatMap pt_ids p_patterns
+      uniqueNames "identity definition" $ p_identdefs <> concatMap pt_ids p_patterns
       identdefs   <- traverse (pIdentity2aIdentity contextInfo Nothing) p_identdefs --  The identity definitions defined in this context, outside the scope of patterns
-      uniqueNames $ p_viewdefs <> concatMap pt_vds p_patterns
+      uniqueNames "view definition" $ p_viewdefs <> concatMap pt_vds p_patterns
       viewdefs    <- traverse (pViewDef2aViewDef contextInfo) p_viewdefs    --  The view definitions defined in this context, outside the scope of patterns
-      uniqueNames p_interfaces
+      uniqueNames "interface" p_interfaces
       interfaces  <- traverse (pIfc2aIfc contextInfo) (p_interfaceAndDisambObjs declMap)   --  TODO: explain   ... The interfaces defined in this context, outside the scope of patterns
       purposes    <- traverse (pPurp2aPurp contextInfo) p_purposes          --  The purposes of objects defined in this context, outside the scope of patterns
       udpops      <- traverse (pPop2aPop contextInfo) p_pops --  [Population]
@@ -709,7 +709,7 @@ pCtx2aCtx env
          P_Box{}
            -> addWarnings warnings $
                        build <$> traverse (join . fmap fn . typecheckObjDef ci) l 
-                             <*  uniqueNames l  -- ensure that each label in a box has a unique name.
+                             <*  uniqueNames "label in box" l  -- ensure that each label in a box has a unique name.
                              <*  mustBeObject (target objExpr)
                   where l :: [P_BoxItem (TermPrim, DisambPrim)]
                         l = si_box x

src/Ampersand/ADL1/PrettyPrinters.hs

@@ -129,7 +129,7 @@ instance Pretty P_Pattern where
           <+\> perline vds
           <+\> perline xps
           <+\> perline pop
-          <+>  text "ENDPATTERN"
+          <+\> text "ENDPATTERN"
 
 instance Pretty P_Relation where
     pretty (P_Sgn nm sign prps pragma mean _) =
@@ -334,9 +334,7 @@ instance Pretty P_Concept where
     pretty P_ONE = text "ONE"
 
 instance Pretty P_Sign where
-    pretty (P_Sign src tgt) = brackets (pretty src <> maybeTgt)
-        where maybeTgt = if src == tgt then empty
-                         else text "*" <> pretty tgt
+    pretty (P_Sign src tgt) = brackets (pretty src <> text "*" <> pretty tgt)
 
 instance Pretty PClassify where
     pretty p = 

src/Ampersand/Core/ParseTree.hs

@@ -215,7 +215,7 @@ data P_Relation =
 --   It is easy to see that if the locations are the same, then the relations must be the same.
 --   But is that true all the time? ... No. If one or both origins are unknown, we revert to comparing name and signature.
 --   This is still not true for MEATGRINDER stuff!
-
+--   So,
 -- DO NOT USE ORD and EQ on P_Relation!
 instance Named P_Relation where
  name = dec_nm
@@ -579,7 +579,7 @@ newtype PMeaning = PMeaning P_Markup
 newtype PMessage = PMessage P_Markup
          deriving Show
 data P_Markup =
-    P_Markup  { mLang   ::   Maybe Lang
+    P_Markup  { mLang   :: Maybe Lang
               , mFormat :: Maybe PandocFormat
               , mString :: Text
               } deriving (Show,Eq) -- for debugging only

src/Ampersand/Daemon/Parser.hs

@@ -15,22 +15,26 @@ import qualified RIO.NonEmpty as NE
 import           Ampersand.FSpec.MetaModels
 import           Ampersand.Types.Config
 import           Ampersand.Options.FSpecGenOptsParser
+import           Ampersand.Misc.HasClasses (HasDaemonOpts(..), showWarningsL)
 
 -- | parseProject will try to parse a file. If it succeeds, it will 
 --   also parse all INCLUDED files transitive. All of these parses could
 --   fail. It will return a tuple containing the Loads and a list of 
 --   the filepaths that are read. 
-parseProject :: (HasRunner env) => 
+parseProject :: (HasDaemonOpts env, HasRunner env) => 
                 FilePath ->  RIO env ([Load],[FilePath])
 parseProject rootAdl = do
+    env1 <- ask
     let fSpecGenOpts = defFSpecGenOpts rootAdl 
     extendWith fSpecGenOpts $ do 
         (pc,gPctx) <- parseFileTransitive rootAdl 
-        env <- ask
+        env2 <- ask
         let loadedFiles = map pcCanonical pc
-            gActx = join $ pCtx2Fspec env <$> gPctx
+            gActx = join $ pCtx2Fspec env2 <$> gPctx
         return ( case gActx of
-                Checked _ ws -> map warning2Load $ ws
+                Checked _ ws 
+                   | view showWarningsL env1 -> map warning2Load ws
+                   | otherwise -> [] 
                 Errors  es   -> NE.toList . fmap error2Load $ es
                , loadedFiles
                )

src/Ampersand/FSpec/ToFSpec/CreateFspec.hs

@@ -107,9 +107,9 @@ cook :: (HasFSpecGenOpts env) =>
       -> Map MetaModel GrindInfo -- ^ A map containing all GrindInfo that could be required
       -> Guarded P_Context  -- ^ The original user's P_Context, Guarded because it might have errors 
       -> Guarded P_Context 
-cook env (BuildRecipe start steps) grindInfoMap user = 
+cook env (BuildRecipe start steps) grindInfoMap userScript = 
     join $ doSteps <$> case start of
-                    UserScript -> user
+                    UserScript -> userScript
                     MetaScript mm -> pure . pModel $ gInfo mm
   where 
   doSteps :: P_Context -> Guarded P_Context
@@ -120,7 +120,7 @@ cook env (BuildRecipe start steps) grindInfoMap user =
         case step of 
           EncloseInConstraints -> pure $ encloseInConstraints ctx 
           Grind mm -> grind (gInfo mm) <$> (pCtx2Fspec env ctx)
-          MergeWith recipe -> mergeContexts ctx <$> cook env recipe grindInfoMap user
+          MergeWith recipe -> mergeContexts ctx <$> cook env recipe grindInfoMap userScript
   gInfo :: MetaModel -> GrindInfo
   gInfo mm = case Map.lookup mm grindInfoMap of
             Just x -> x

src/Ampersand/Graphic/Graphics.hs

@@ -281,7 +281,7 @@ instance ReferableFromPandoc Picture where
       extention =
          case view fspecFormatL env of
            Fpdf   -> "png"   -- If Pandoc makes a PDF file, the pictures must be delivered in .png format. .pdf-pictures don't seem to work.
-           Fdocx  -> "svg"   -- If Pandoc makes a .docx file, the pictures are delivered in .svg format for scalable rendering in MS-word.
+           Fdocx  -> "png"   -- If Pandoc makes a .docx file, the pictures are delivered in .svg format for scalable rendering in MS-word.
            Fhtml  -> "png"
            _      -> "pdf"
 

src/Ampersand/Input/ADL1/CtxError.hs

@@ -8,7 +8,7 @@ module Ampersand.Input.ADL1.CtxError
   , cannotDisambiguate
   , mustBeOrdered, mustBeOrderedLst, mustBeOrderedConcLst
   , mustBeBound
-  , GetOneGuarded(..), uniqueNames, uniqueBy
+  , GetOneGuarded(..), uniqueNames
   , unexpectedType
   , mkErrorReadingINCLUDE
   , mkDanglingPurposeError
@@ -246,22 +246,26 @@ cannotDisambiguate o x = Errors . pure $ CTXE (origin o) message
              EDcD rel -> " ("<>tshow (origin rel)<>")"
              EFlp e' -> showA' e'
              _ -> ""
+-- | Rules, identity statements, view definitions, interfaces, and box labels
+--   need unique names. The `nameclass` ("rule", "interface", etc.) is used to
+--   provide a more meaningful error message.
 uniqueNames :: (Named a, Traced a) =>
-                     [a] -> Guarded ()
-uniqueNames = uniqueBy name
-uniqueBy :: (Traced a, Show b, Ord b) => (a -> b) -> [a] -> Guarded ()
-uniqueBy fun a = case (filter moreThanOne . groupWith fun) a of
-                  []   -> pure ()
-                  x:xs -> Errors . fmap messageFor $ x NE.:| xs
-    where
-     moreThanOne (_:_:_) = True
-     moreThanOne  _      = False
-     messageFor (x:xs) = CTXE (origin x)
-                      ("Names / labels must be unique. "<>(tshow . fun) x<>", however, is used at:"
-                      <>  T.intercalate ("\n    ") (map (tshow . origin) (x:xs))
-                      <>  "."
-                      )
-     messageFor _ = fatal "messageFor must only be used on lists with more that one element!"
+                     Text -> [a] -> Guarded ()
+uniqueNames nameclass = uniqueBy name
+  where
+    uniqueBy :: (Traced a, Show b, Ord b) => (a -> b) -> [a] -> Guarded ()
+    uniqueBy fun a = case (filter moreThanOne . groupWith fun) a of
+                      []   -> pure ()
+                      x:xs -> Errors . fmap messageFor $ x NE.:| xs
+      where
+        messageFor (x:xs) = CTXE (origin x)
+                         ("Every "<>nameclass<>" must have a unique name. "<>(tshow . fun) x<>", however, is used at:"
+                         <>  T.intercalate ("\n    ") (map (tshow . origin) (x:xs))
+                         <>  "."
+                         )
+        messageFor _ = fatal "messageFor must only be used on lists with more that one element!"
+    moreThanOne (_:_:_) = True
+    moreThanOne  _      = False
 
 mkDanglingPurposeError :: Purpose -> CtxError
 mkDanglingPurposeError p = CTXE (origin p) $ "Purpose refers to non-existent " <> showA (explObj p)