diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 639745c4d9..378a6e5681 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,5 +1,12 @@ # Release notes of Ampersand +## Unreleased changes + +## v3.11.2 (31 august 2018) + +* [Issue #821](https://github.com/AmpersandTarski/Ampersand/issues/821) Fix error messages. +* Exit codes: code 20 was erroneously called 10. On 8 august 2018 this was discovered and fixed in `Exit.hs` when documenting error codes. + ## v3.11.1 (3 august 2018) * [Issue #814](https://github.com/AmpersandTarski/Ampersand/issues/814) More clear error message. diff --git a/ampersand.cabal b/ampersand.cabal index df307b7fa7..3c1b8978c9 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -1,8 +1,8 @@ name: ampersand -version: 3.11.1 +version: 3.11.2 author: Stef Joosten maintainer: stef.joosten@ou.nl -synopsis: Toolsuite for automated design of business processes. +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 diff --git a/src/Ampersand/ADL1/Disambiguate.hs b/src/Ampersand/ADL1/Disambiguate.hs index 2b74877a48..0c8b30bda7 100644 --- a/src/Ampersand/ADL1/Disambiguate.hs +++ b/src/Ampersand/ADL1/Disambiguate.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE DuplicateRecordFields,OverloadedLabels #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} module Ampersand.ADL1.Disambiguate ( disambiguate , orWhenEmpty @@ -217,6 +220,8 @@ data DisambPrim deriving Show -- Here, deriving Show serves debugging purposes only. instance Pretty DisambPrim where pretty = text . show +instance Pretty a => Pretty (a,DisambPrim) where + pretty (t,_) = pretty t performUpdate :: ((t, DisambPrim), Constraints) -> Change (t, DisambPrim) diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index 8003139b25..7ad134950b 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -1,8 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + module Ampersand.ADL1.PrettyPrinters(Pretty(..),prettyPrint) where -import Ampersand.Basics +import Ampersand.Basics hiding ((<$>)) import Ampersand.Core.ParseTree import Ampersand.Input.ADL1.Lexer(keywords) import Data.Char (toUpper) @@ -163,14 +166,14 @@ instance Pretty a => Pretty (Term a) where PRad _ t1 t2 -> two t1 t2 "!" PPrd _ t1 t2 -> two t1 t2 "#" -- level 5 - PKl0 _ t -> pos' t "*" - PKl1 _ t -> pos' t "+" - PFlp _ t -> pos' t "~" + PKl0 _ t -> post t "*" + PKl1 _ t -> post t "+" + PFlp _ t -> post t "~" PCpl _ t -> pre t " -" -- a double dash can happen when combined with PDif, therefore the extra space -- level 6 PBrk _ t -> parens $ pretty t - where pos' t op = pretty t <> text op + where post t op = pretty t <> text op pre t op = text op <> pretty t two t1 t2 op = pretty t1 <> text op <> pretty t2 @@ -190,10 +193,15 @@ instance Pretty TermPrim where instance Pretty P_NamedRel where pretty (PNamedRel _ str mpSign) = text (takeQuote str) <~> mpSign -instance Pretty a => Pretty (PairView a) where +instance Pretty (PairView TermPrim) where + pretty (PairView ss) = text "VIOLATION" <+> parens (listOf1 ss) +instance Pretty (PairView (Term TermPrim)) where pretty (PairView ss) = text "VIOLATION" <+> parens (listOf1 ss) -instance Pretty a => Pretty (PairViewSegment a) where +instance Pretty (PairViewSegment TermPrim) where + pretty (PairViewText _ str) = text "TXT" <+> quote str + pretty (PairViewExp _ srcTgt term) = pretty srcTgt <~> term +instance Pretty (PairViewSegment (Term TermPrim)) where pretty (PairViewText _ str) = text "TXT" <+> quote str pretty (PairViewExp _ srcTgt term) = pretty srcTgt <~> term @@ -201,7 +209,7 @@ instance Pretty SrcOrTgt where pretty Src = text "SRC" pretty Tgt = text "TGT" -instance Pretty a => Pretty (P_Rule a) where +instance Pretty (P_Rule TermPrim) where pretty (P_Ru _ nm expr mean msg viol) = text "RULE" <+> rName <~> expr <+\> @@ -236,7 +244,7 @@ instance Pretty P_Interface where <+> iroles <+> (case obj of P_BxExpr{} -> - text ":" <~\> obj_ctx obj <~> obj_msub obj + nest 2 (text ":" <+> pretty (obj_ctx obj) <$> pretty (obj_msub obj)) P_BxTxt {} -> fatal "TXT must not be used directly in a P_Ifc." ) where iroles = if null roles then empty @@ -247,7 +255,7 @@ instance Pretty a => Pretty (P_BoxItem a) where maybeQuote (name obj) <+> text ":" <+> case obj of (P_BxExpr _ _ ctx mCrud mView msub) - -> pretty ctx <+> crud mCrud <+> view mView <~> msub + -> nest 2 (pretty ctx <+> crud mCrud <+> view mView <$> pretty msub) (P_BxTxt _ _ str) -> text "TXT" <+> quote str @@ -264,11 +272,11 @@ instance Pretty a => Pretty (P_SubIfc a) where where box_type Nothing = text "BOX" box_type (Just x) = text x -- ROWS, COLS, TABS -instance Pretty a => Pretty (P_IdentDf a) where +instance Pretty (P_IdentDf TermPrim) where pretty (P_Id _ lbl cpt ats) = text "IDENT" <+> maybeQuote lbl <+> text ":" <~> cpt <+> parens (listOf ats) -instance Pretty a => Pretty (P_IdentSegmnt a) where +instance Pretty (P_IdentSegmnt TermPrim) where pretty (P_IdentExp obj) = case obj of (P_BxExpr nm _ ctx _ mView _) @@ -282,7 +290,7 @@ instance Pretty a => Pretty (P_IdentSegmnt a) where where view Nothing = empty view (Just v) = pretty v -instance Pretty a => Pretty (P_ViewD a) where +instance Pretty (P_ViewD TermPrim) where pretty (P_Vd _ lbl cpt True Nothing ats) = -- legacy syntax text "VIEW" <+> maybeQuote lbl <+> text ":" <~> cpt <+> parens (listOf ats) @@ -293,13 +301,13 @@ instance Pretty a => Pretty (P_ViewD a) where instance Pretty ViewHtmlTemplate where pretty (ViewHtmlTemplateFile str) = text "HTML" <+> text "TEMPLATE" <+> quote str -instance Pretty a => Pretty (P_ViewSegment a) where +instance Pretty (P_ViewSegment TermPrim) where pretty (P_ViewSegment mlab _ pl) = ( case mlab of Nothing -> empty Just str -> maybeQuote str <+> text ":" ) <~> pretty pl -instance Pretty a => Pretty (P_ViewSegmtPayLoad a) where +instance Pretty (P_ViewSegmtPayLoad TermPrim) where pretty (P_ViewExp expr) = pretty expr pretty (P_ViewText txt) = text "TXT" <+> quote txt diff --git a/src/Ampersand/Basics/Exit.hs b/src/Ampersand/Basics/Exit.hs index db73f2c1b5..c3fff6c990 100644 --- a/src/Ampersand/Basics/Exit.hs +++ b/src/Ampersand/Basics/Exit.hs @@ -43,7 +43,7 @@ info x = _ -> msg ) ViolationsInDatabase viols - -> (SE.ExitFailure 10 , "ERROR: The population would violate invariants. Could not generate your database." : concatMap showViolatedRule viols) + -> (SE.ExitFailure 20 , "ERROR: The population would violate invariants. Could not generate your database." : concatMap showViolatedRule viols) InvalidSQLExpression msg -> (SE.ExitFailure 30 , "ERROR: Invalid SQL Expression" : map (" "++) msg) NoPrototypeBecauseOfRuleViolations diff --git a/src/Ampersand/Input.hs b/src/Ampersand/Input.hs index 732a5b603d..8c92fc7367 100644 --- a/src/Ampersand/Input.hs +++ b/src/Ampersand/Input.hs @@ -3,5 +3,5 @@ module Ampersand.Input , module Ampersand.Input.Parsing ) where import Ampersand.Input.ADL1.CtxError (CtxError,Guarded(..),showErr) -import Ampersand.Input.Parsing (parseADL,parseMeta,parseSystemContext,parseRule,parseCtx,runParser) +import Ampersand.Input.Parsing (parseADL,parseMeta,parseSystemContext,parseRule,runParser) \ No newline at end of file diff --git a/src/Ampersand/Input/ADL1/CtxError.hs b/src/Ampersand/Input/ADL1/CtxError.hs index 68a037277d..adf7f76185 100644 --- a/src/Ampersand/Input/ADL1/CtxError.hs +++ b/src/Ampersand/Input/ADL1/CtxError.hs @@ -336,19 +336,23 @@ mustBeOrdered o a b , " and concept "++showEC b ] -mustBeOrderedLst :: Pretty x => P_SubIfc (TermPrim, x) -> [(A_Concept, SrcOrTgt, P_BoxItem TermPrim)] -> Guarded b +mustBeOrderedLst :: P_SubIfc (TermPrim, DisambPrim) -> [(A_Concept, SrcOrTgt, P_BoxItem TermPrim)] -> Guarded b mustBeOrderedLst o lst = Errors . pure . CTXE (origin o) . unlines $ - [ "Type error in "++showP o + [ "Type error in BOX" , " Cannot match:" ]++ - [ " - concept "++showA c++", "++show st++" of "++showP a + [ " - concept "++showA c++" , "++showP st++" of: "++showP (exprOf a) | (c,st,a) <- lst ]++ [ " if you think there is no type error, add an order between the mismatched concepts." , " You can do so by using a CLASSIFY statement." ] - + where exprOf :: P_BoxItem TermPrim -> Term TermPrim + exprOf x = + case x of + P_BxExpr{} -> obj_ctx x + P_BxTxt{} -> fatal "How can a type error occur with a TXT field???" mustBeOrderedConcLst :: Origin -> (SrcOrTgt, Expression) -> (SrcOrTgt, Expression) -> [[A_Concept]] -> Guarded (A_Concept, [A_Concept]) mustBeOrderedConcLst o (p1,e1) (p2,e2) cs = Errors . pure . CTXE (origin o) . unlines $ diff --git a/src/Ampersand/Input/Parsing.hs b/src/Ampersand/Input/Parsing.hs index d09e4be2db..0dc6617f6f 100644 --- a/src/Ampersand/Input/Parsing.hs +++ b/src/Ampersand/Input/Parsing.hs @@ -7,7 +7,6 @@ module Ampersand.Input.Parsing ( , parseMeta , parseSystemContext , parseRule - , parseCtx , runParser ) where diff --git a/stack.yaml b/stack.yaml index 5ed2d57fce..c5b0a15e07 100644 --- a/stack.yaml +++ b/stack.yaml @@ -21,7 +21,7 @@ extra-deps: # Override default flag values for local packages and extra-deps flags: {} -# Make sure we can allready use GHC 7.10.3: (See https://www.fpcomplete.com/blog/2015/12/stack-with-ghc-7-10-3) +# Make sure we can already use GHC 7.10.3: (See https://www.fpcomplete.com/blog/2015/12/stack-with-ghc-7-10-3) # compiler-check: newer-minor # Extra package databases containing global packages