[tests] add more errors and their tests

src/MiniJuvix/Syntax/Concrete/Scoped/Error.hs

@@ -24,7 +24,7 @@ data ScopeError
   | ErrSymNotInScope NotInScope
   | ErrQualSymNotInScope QualifiedName
   | ErrModuleNotInScope Name
-  | ErrBindGroup Symbol
+  | ErrBindGroup BindGroupConflict
   | ErrDuplicateFixity Symbol
   | ErrMultipleExport Symbol
   | ErrAmbiguousSym [SymbolEntry]
@@ -46,7 +46,7 @@ ppScopeError s = case s of
   ErrSymNotInScope e -> ppError e
   ErrQualSymNotInScope {} -> ugly
   ErrModuleNotInScope {} -> ugly
-  ErrBindGroup {} -> ugly
+  ErrBindGroup e -> ppError e
   ErrDuplicateFixity {} -> ugly
   ErrMultipleExport {} -> ugly
   ErrAmbiguousSym {} -> ugly

src/MiniJuvix/Syntax/Concrete/Scoped/Error/Pretty/Base.hs

@@ -45,7 +45,8 @@ instance PrettyError InfixError where
     infixErrorAux "expression" (ppCode _infixErrAtoms)
 
 instance PrettyError InfixErrorP where
-  ppError InfixErrorP {..} = infixErrorAux "pattern" (ppCode _infixErrAtomsP)
+  ppError InfixErrorP {..} =
+    infixErrorAux "pattern" (ppCode _infixErrAtomsP)
 
 infixErrorAux :: Doc Eann -> Doc Eann -> Doc Eann
 infixErrorAux kind pp =
@@ -90,3 +91,11 @@ instance PrettyError NotInScope where
     candidates :: HashSet Text
     candidates = HashSet.fromList (map _symbolText (HashMap.keys $ _localVars _notInScopeLocal)) <>
       HashSet.fromList (map _symbolText (HashMap.keys $ _scopeSymbols _notInScopeScope))
+
+instance PrettyError BindGroupConflict where
+  ppError BindGroupConflict {..} =
+    "The symbol" <+> highlight (ppCode _bindGroupFirst)
+      <+> "appears twice in the same binding group:" <> line
+    <> indent' (align locs)
+    where
+      locs = vsep $ map (pretty . getLoc) [_bindGroupFirst , _bindGroupSecond]

src/MiniJuvix/Syntax/Concrete/Scoped/Error/Types.hs

@@ -44,3 +44,9 @@ data NotInScope = NotInScope {
  _notInScopeScope :: Scope
  }
  deriving stock (Show)
+
+data BindGroupConflict = BindGroupConflict {
+ _bindGroupFirst :: Symbol,
+ _bindGroupSecond :: Symbol
+ }
+ deriving stock (Show)

src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs

@@ -823,7 +823,7 @@ withBindLocalVariable ::
   Sem r a
 withBindLocalVariable var = local (addLocalVars [var])
 
--- | Binds a local variable in a bind group, i.e. a pattern.
+-- | Binds a local variable in a bind group, i.e. a group of pattern.
 groupBindLocalVariable ::
   forall r.
   Members '[Error ScopeError, State Scope, State ScoperState] r =>
@@ -837,7 +837,11 @@ groupBindLocalVariable s = do
     checkNotInGroup =
       whenJustM
         (HashMap.lookup s <$> gets _scopeBindGroup)
-        (const (throw (ErrBindGroup s)))
+        (\x -> throw (ErrBindGroup
+            BindGroupConflict {
+                _bindGroupFirst = S._nameConcrete (variableName x),
+                _bindGroupSecond =  s
+                }))
     addToGroup :: Sem r S.Symbol
     addToGroup = do
       n <- freshVariable s

test/Scope/Negative.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use lambda-case" #-}
 module Scope.Negative (allTests) where
 
 import Base
@@ -8,7 +10,7 @@ type FailMsg = String
 
 data NegTest = NegTest {
   name :: String,
-  dir :: Maybe FilePath,
+  relDir :: FilePath,
   file :: FilePath,
   checkErr :: ScopeError -> Maybe FailMsg
   }
@@ -16,7 +18,7 @@ data NegTest = NegTest {
 instance IsTest NegTest where
   testDescr NegTest {..} = TestDescr {
     testName = name,
-    testRoot = maybe root (root </>) dir,
+    testRoot = root </> relDir,
     testAssertion = do
         p <- parseModuleIO file >>= M.scopeCheck1 "."
         case p of
@@ -27,20 +29,56 @@ instance IsTest NegTest where
 root :: FilePath
 root = "tests/negative"
 
+wrongError :: Maybe FailMsg
 wrongError = Just "Incorrect error"
 
 tests :: [NegTest]
 tests = [
-  NegTest "Not in scope" Nothing
-   "NotInScope.mjuvix" $ (\er ->
+  NegTest "Not in scope" "."
+   "NotInScope.mjuvix" $ \er ->
       case er of
         ErrSymNotInScope{} -> Nothing
-        _ -> wrongError)
-  ,  NegTest "Multiple declarations" Nothing
-   "MultipleDeclarations.mjuvix" $ (\er ->
+        _ -> wrongError
+
+  ,  NegTest "Multiple declarations" "."
+   "MultipleDeclarations.mjuvix" $ \er ->
       case er of
         ErrMultipleDeclarations{} -> Nothing
-        _ -> wrongError)
+        _ -> wrongError
+
+  ,  NegTest "Import Cycle" "ImportCycle"
+   "A.mjuvix" $ \er ->
+      case er of
+        ErrImportCycle {} -> Nothing
+        _ -> wrongError
+
+  ,  NegTest "Binding group conflict (function clause)"
+    "BindGroupConflict"
+   "Clause.mjuvix" $ \er ->
+      case er of
+        ErrBindGroup {} -> Nothing
+        _ -> wrongError
+
+  ,  NegTest "Binding group conflict (lambda clause)"
+    "BindGroupConflict"
+   "Lambda.mjuvix" $ \er ->
+      case er of
+        ErrBindGroup {} -> Nothing
+        _ -> wrongError
+
+  ,  NegTest "Infix error (expression)"
+    "."
+   "InfixError.mjuvix" $ \er ->
+      case er of
+        ErrInfixParser {} -> Nothing
+        _ -> wrongError
+
+  ,  NegTest "Infix error (pattern)"
+    "."
+   "InfixErrorP.mjuvix" $ \er ->
+      case er of
+        ErrInfixPattern {} -> Nothing
+        _ -> wrongError
 
   ]
 

tests/negative/BindGroupConflict/Clause.mjuvix

@@ -0,0 +1,10 @@
+module Clause;
+
+  inductive Pair (a : Type) (b : Type) {
+   mkPair : a → b → Pair a b
+  };
+
+  fst : (a : Type) → (b : Type) → Pair a b → a ;
+  fst _ _ (mkPair _ _ x x) ≔ x;
+
+end;

tests/negative/BindGroupConflict/Lambda.mjuvix

@@ -0,0 +1,10 @@
+module Lambda;
+
+  inductive Pair (a : Type) (b : Type) {
+   mkPair : a → b → Pair a b
+  };
+
+  fst : (a : Type) → (b : Type) → Pair a b → a ;
+  fst ≔ λ { _ _ (mkPair _ _ x x) ↦ x };
+
+end;

tests/negative/InfixErrorP.mjuvix

@@ -0,0 +1,12 @@
+module InfixErrorP;
+
+  infix 5 , ;
+
+  inductive Pair {
+   , : Type → Type → Pair
+  };
+
+  fst : Pair → Type;
+  fst (x , ) ≔ x;
+
+end;