Merge pull request #1111 from AmpersandTarski/development

Release 4.1.1.

.github/workflows/build-push-to-docker-hub.yml

@@ -9,7 +9,7 @@ on:
     - development
   release:
     types:
-    - created
+    - published
 
 jobs:
   build-push:

ReleaseNotes.md

@@ -1,5 +1,9 @@
 # Release notes of Ampersand
 
+## v4.1.1 (11 september 2020)
+
+* [Issue #1107](https://github.com/AmpersandTarski/Ampersand/issues/1107) Daemon doesn't correctly ignore invariant violations
+
 ## v4.1.0 (14 august 2020)
 
 * [Issue #1067](https://github.com/AmpersandTarski/Ampersand/issues/1067) Docker build push to Docker hub instead of Github package repo

package.yaml

@@ -1,5 +1,5 @@
 name:           ampersand
-version:        4.1.0.1
+version:        4.1.1
 author:         Stef Joosten
 maintainer:     [email protected]
 synopsis:       Toolsuite for automated design of enterprise information systems.

src/Ampersand/Commands/Devoutput.hs

@@ -21,13 +21,13 @@ import           System.Directory
 import           System.FilePath
 -- | Dumps diagnostic output for development purposes
 --
-devoutput :: (HasDirOutput env, HasRootFile env, HasLogFunc env) 
+devoutput :: (HasDirOutput env, HasFSpecGenOpts env, HasLogFunc env) 
        => FSpec -> RIO env ()
 devoutput fSpec = do
     doGenHaskell fSpec
     doGenSQLdump fSpec
 
-doGenHaskell :: (HasDirOutput env, HasRootFile env, HasLogFunc env) 
+doGenHaskell :: (HasDirOutput env, HasFSpecGenOpts env, HasLogFunc env) 
        => FSpec -> RIO env ()
 doGenHaskell fSpec = do
     env <- ask
@@ -40,7 +40,7 @@ doGenHaskell fSpec = do
   where 
     outputFile' env = view dirOutputL env </> baseName env -<.> ".hs"
 
-doGenSQLdump :: (HasDirOutput env, HasRootFile env, HasLogFunc env) 
+doGenSQLdump :: (HasDirOutput env, HasFSpecGenOpts env, HasLogFunc env) 
        => FSpec -> RIO env ()
 doGenSQLdump fSpec = do
     env <- ask

src/Ampersand/Commands/Documentation.hs

@@ -13,7 +13,7 @@ import           RIO.Time
 -- the returned FSpec contains the details about the Pictures, so they
 -- can be referenced while rendering the FSpec.
 -- This function generates a pandoc document, possibly with pictures from an fSpec.
-doGenDocument :: (HasBlackWhite env, HasRootFile env, HasDirOutput env, HasLogFunc env, HasDocumentOpts env) 
+doGenDocument :: (HasBlackWhite env, HasFSpecGenOpts env, HasDirOutput env, HasLogFunc env, HasDocumentOpts env) 
    => FSpec -> RIO env ()
 doGenDocument fSpec = do
     env <- ask

src/Ampersand/Commands/Population.hs

@@ -25,7 +25,7 @@ import           Text.Pandoc.Error(handleError)
 
 -- | Builds a file containing the population of the current project.
 --   depending on a switch this could be an .xlsx file or a json file. 
-population :: (HasPopulationOpts env, HasDirOutput env, HasRootFile env,HasLogFunc env)
+population :: (HasPopulationOpts env, HasDirOutput env, HasFSpecGenOpts env,HasLogFunc env)
        => FSpec -> RIO env ()
 population fSpec = do
         env <- ask

src/Ampersand/Commands/Proof.hs

@@ -22,7 +22,7 @@ import           Text.Pandoc.Builder
 
 -- | Generate a proofs output document from a project.
 --
-proof :: (HasDirOutput env, HasRootFile env, HasLogFunc env) 
+proof :: (HasDirOutput env, HasFSpecGenOpts env, HasLogFunc env) 
        => FSpec -> RIO env ()
 proof fSpec = do 
     env <- ask

src/Ampersand/Commands/Proto.hs

@@ -20,7 +20,7 @@ import qualified RIO.Text as T
 import           System.Directory
 -- | Builds a prototype of the current project.
 --
-proto :: (Show env, HasRunner env, HasDirCustomizations env, HasZwolleVersion env, HasProtoOpts env, HasDirPrototype env, HasGenerateFrontend env, HasGenerateBackend env) 
+proto :: (Show env, HasRunner env, HasFSpecGenOpts env, HasDirCustomizations env, HasZwolleVersion env, HasProtoOpts env, HasDirPrototype env, HasGenerateFrontend env, HasGenerateBackend env) 
        => FSpec -> RIO env ()
 proto fSpec = do
     env <- ask

src/Ampersand/Commands/Uml.hs

@@ -20,7 +20,7 @@ import           System.Directory
 import           System.FilePath
 -- | Generate a UML output file from a project.
 --
-uml :: (HasDirOutput env, HasRootFile env, HasLogFunc env, HasOutputLanguage env) 
+uml :: (HasDirOutput env, HasFSpecGenOpts env, HasLogFunc env, HasOutputLanguage env) 
     => FSpec -> RIO env ()
 uml fSpec = do
    env <- ask

src/Ampersand/Daemon/Parser.hs

@@ -14,26 +14,23 @@ import           Ampersand.Input.ADL1.CtxError
 import qualified RIO.NonEmpty as NE
 import           Ampersand.FSpec.MetaModels
 import           Ampersand.Types.Config
-import           Ampersand.Options.FSpecGenOptsParser
-import           Ampersand.Misc.HasClasses (HasDaemonOpts(..), showWarningsL)
+import           Ampersand.Misc.HasClasses (HasRootFile(..),rootFileL, 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
+--   also parse all INCLUDED files transitive. Any of these parses could
 --   fail. It will return a tuple containing the Loads and a list of 
 --   the filepaths that are read. 
 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 
-        env2 <- ask
-        let loadedFiles = map pcCanonical pc
-            gActx = join $ pCtx2Fspec env2 <$> gPctx
-        return ( case gActx of
+parseProject rootAdl =  local (set rootFileL (Just rootAdl)) $ do
+    showWarnings <- view showWarningsL
+    (pc,gPctx) <- parseFileTransitive rootAdl 
+    env <- ask
+    let loadedFiles = map pcCanonical pc
+        gActx = join $ pCtx2Fspec env <$> gPctx
+    return ( case gActx of
                 Checked _ ws 
-                   | view showWarningsL env1 -> map warning2Load ws
+                   | showWarnings -> map warning2Load ws
                    | otherwise -> [] 
                 Errors  es   -> NE.toList . fmap error2Load $ es
                , loadedFiles

src/Ampersand/FSpec/ShowHS.hs

@@ -20,7 +20,7 @@ import qualified RIO.Text as T
 import           RIO.Time
 import           Text.Pandoc hiding (Meta)
 
-fSpec2Haskell :: (HasRootFile env) =>
+fSpec2Haskell :: (HasFSpecGenOpts env) =>
        env -> UTCTime -> FSpec -> Text
 fSpec2Haskell env now fSpec
     = T.intercalate "\n" $
@@ -51,7 +51,7 @@ class ShowHSName a where
  showHSName :: a -> Text
 
 class ShowHS a where
- showHS :: (HasRootFile env) => env -> Text -> a -> Text
+ showHS :: (HasFSpecGenOpts env) => env -> Text -> a -> Text
 
 instance ShowHSName a => ShowHSName [a] where
  showHSName xs = "["<>T.intercalate "," (map showHSName xs)<>"]"

src/Ampersand/FSpec/ToFSpec/CreateFspec.hs

@@ -40,7 +40,7 @@ import qualified RIO.Set as Set
 --   The combination of model and populated metamodel results in the Guarded FSpec,
 --   which is the result of createFSpec.
 
-createFspec :: (HasFSpecGenOpts env, HasRootFile env, HasLogFunc env) => 
+createFspec :: (HasFSpecGenOpts env, HasLogFunc env) => 
                BuildRecipe -> RIO env (Guarded FSpec)
 createFspec recipe = do 
     env <- ask

src/Ampersand/Input/Parsing.hs

@@ -120,7 +120,7 @@ parseSingleADL pc
  = do case pcFileKind pc of
         Just _ -> {- reading a file that is included into ampersand.exe -} 
                    logDebug $ "Reading internal file " <> display (T.pack filePath) 
-        Nothing -> logInfo $ "Reading file " <> display (T.pack filePath) 
+        Nothing -> logDebug $ "Reading file " <> display (T.pack filePath) 
       exists <- liftIO $ doesFileExist filePath
       if isJust (pcFileKind pc) || exists
       then parseSingleADL'

src/Ampersand/Misc/Commands.hs

@@ -63,7 +63,7 @@ commandLineHandler
   -> [Text] -- the (command-line) arguments
   -> IO (GlobalOptsMonoid, RIO Runner ())
 commandLineHandler currentDir _progName args = complicatedOptions
-  ampersandVersionWithoutBuildTimeStr
+  ampersandVersionStr
   "ampersand - The Ampersand generator"
   ""
   "ampersand's documentation is available at https://ampersandtarski.gitbook.io/documentation/"

src/Ampersand/Misc/HasClasses.hs

@@ -87,34 +87,9 @@ class HasRootFile a where
   dirSource = fromMaybe (fatal "Cannot determine the directory of the script that is being compiled")
             . fmap takeDirectory 
             . view rootFileL
-instance HasRootFile ProtoOpts where
-  rootFileL = fSpecGenOptsL . rootFileL
-instance HasRootFile FSpecGenOpts where
-  rootFileL = lens xrootFile (\x y -> x { xrootFile = y })
-              --Note: This instance definition is different, because
-              --      we need a construction that in case of the deamon
-              --      command, the root wil actually be read from a
-              --      config file.  
-  --   lens (\x -> fromMaybe
-  --                  (fatal "The rootfile must be set before it is read!")
-  --                  (xrootFile x)
-  --        )
-  --        (\x y -> x { xrootFile = Just y })
+instance (HasFSpecGenOpts a) => HasRootFile a where
+  rootFileL = fSpecGenOptsL . (lens xrootFile (\x y -> x { xrootFile = y }))
 
-instance HasRootFile DocOpts where
-  rootFileL = fSpecGenOptsL . rootFileL
-instance HasRootFile InputOutputOpts where
-  rootFileL = fSpecGenOptsL . rootFileL
-instance HasRootFile PopulationOpts where
-  rootFileL = fSpecGenOptsL . rootFileL
-instance HasRootFile ProofOpts where
-  rootFileL = fSpecGenOptsL . rootFileL
-instance HasRootFile UmlOpts where
-  rootFileL = fSpecGenOptsL . rootFileL
-instance HasRootFile ValidateOpts where
-  rootFileL = fSpecGenOptsL . rootFileL
-instance HasRootFile DevOutputOpts where
-  rootFileL = fSpecGenOptsL . rootFileL
 class HasOutputLanguage a where
   languageL :: Lens' a (Maybe Lang)  -- The language in which the user wants the documentation to be printed.
 instance HasOutputLanguage ProtoOpts where

src/Ampersand/Output/PandocAux.hs

@@ -111,7 +111,7 @@ defaultWriterVariables env fSpec
             fun (k,v)= (k, SimpleVal (Text (T.length v) v))
 
 --DESCR -> functions to write the pandoc
-writepandoc :: (HasDirOutput env, HasRootFile env, HasDocumentOpts env, HasLogFunc env) => 
+writepandoc :: (HasDirOutput env, HasFSpecGenOpts env, HasDocumentOpts env, HasLogFunc env) => 
       FSpec -> Pandoc -> RIO env ()
 writepandoc fSpec thePandoc = do
   env <- ask
@@ -122,7 +122,7 @@ writepandoc fSpec thePandoc = do
     fSpecFormatString :: (HasDocumentOpts env) => env -> Text 
     fSpecFormatString = T.toLower . T.drop 1 . tshow . view fspecFormatL
 
-outputFile :: (HasDocumentOpts env, HasRootFile env, HasDirOutput env) => env -> FilePath
+outputFile :: (HasDocumentOpts env, HasFSpecGenOpts env, HasDirOutput env) => env -> FilePath
 outputFile env = view dirOutputL env </> baseName env -<.> ext (view fspecFormatL env) 
 
 ext :: FSpecFormat -> FilePath
@@ -147,7 +147,7 @@ ext format =
         Ftexinfo      -> ".texinfo"
         Ftextile      -> ".textile"
 
-writepandoc' :: (HasDocumentOpts env, HasRootFile env, HasDirOutput env) => env -> FSpec -> Pandoc -> IO ()
+writepandoc' :: (HasDocumentOpts env, HasFSpecGenOpts env, HasDirOutput env) => env -> FSpec -> Pandoc -> IO ()
 writepandoc' env fSpec thePandoc = liftIO . runIOorExplode $ do
   case writer of 
      ByteStringWriter f -> do 

src/Ampersand/Prototype/GenFrontend.hs

@@ -65,7 +65,7 @@ This is considered editable iff the composition rel;relRef yields an editable re
 --       composite attributes in anonymous templates will hang the generator :-(
 --       Eg.  "$subObjects:{subObj| .. $subObj.nonExistentField$ .. }$"
 
-doGenFrontend :: (HasRunner env, HasProtoOpts env, HasZwolleVersion env, HasDirPrototype env) =>
+doGenFrontend :: (HasFSpecGenOpts env, HasRunner env, HasProtoOpts env, HasZwolleVersion env, HasDirPrototype env) =>
                  FSpec -> RIO env ()
 doGenFrontend fSpec = do
     now <- getCurrentTime
@@ -103,7 +103,7 @@ writeFile filePath content = do
   liftIO $ createDirectoryIfMissing True (takeDirectory filePath)
   BL.writeFile filePath content
 
-copyTemplates :: (HasDirPrototype env, HasLogFunc env) =>
+copyTemplates :: (HasFSpecGenOpts env, HasDirPrototype env, HasLogFunc env) =>
                  RIO env ()
 copyTemplates = do
   env <- ask
@@ -116,7 +116,7 @@ copyTemplates = do
   else
          logDebug $ "No project specific templates (there is no directory " <> display (T.pack tempDir) <> ")"
 
-copyCustomizations :: (HasDirPrototype env, HasDirCustomizations env,HasLogFunc env) =>
+copyCustomizations :: (HasDirPrototype env, HasFSpecGenOpts env , HasDirCustomizations env,HasLogFunc env) =>
                       RIO env ()
 copyCustomizations = do
   env <- ask

src/Ampersand/Types/Config.hs

@@ -133,8 +133,6 @@ instance (HasOutputLanguage a) => HasOutputLanguage (ExtendedRunner a) where
   languageL = cmdOptsL . languageL
 instance (HasFSpecGenOpts a) => HasFSpecGenOpts (ExtendedRunner a) where
   fSpecGenOptsL = cmdOptsL . fSpecGenOptsL
-instance (HasRootFile a) => HasRootFile (ExtendedRunner a) where
-  rootFileL = cmdOptsL . rootFileL
 instance (HasDocumentOpts a) => HasDocumentOpts (ExtendedRunner a) where
   documentOptsL = cmdOptsL . documentOptsL
 instance (HasDaemonOpts a) => HasDaemonOpts (ExtendedRunner a) where 
@@ -149,7 +147,7 @@ instance (HasGenerateFrontend a) => HasGenerateFrontend (ExtendedRunner a) where
   generateFrontendL = cmdOptsL . generateFrontendL
 instance (HasGenerateBackend a) => HasGenerateBackend (ExtendedRunner a) where
   generateBackendL = cmdOptsL . generateBackendL
-instance (HasDirPrototype a) => HasDirPrototype (ExtendedRunner a) where
+instance (HasFSpecGenOpts a, HasDirPrototype a) => HasDirPrototype (ExtendedRunner a) where
   dirPrototypeL = cmdOptsL . dirPrototypeL
 instance (HasProtoOpts a) => HasProtoOpts (ExtendedRunner a) where
   protoOptsL = cmdOptsL . protoOptsL