Merge pull request #825 from AmpersandTarski/development

Release 3.11.2

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.

ampersand.cabal

@@ -1,8 +1,8 @@
 name:           ampersand
-version:        3.11.1
+version:        3.11.2
 author:         Stef Joosten
 maintainer:     [email protected]
-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

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)

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,18 +193,23 @@ 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
 
 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
 

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

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)
 

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 $

src/Ampersand/Input/Parsing.hs

@@ -7,7 +7,6 @@ module Ampersand.Input.Parsing (
     , parseMeta
     , parseSystemContext
     , parseRule
-    , parseCtx
     , runParser
 ) where
 

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