From ec8d554af1e7d8cf5f7527145dba925b6f8db663 Mon Sep 17 00:00:00 2001
From: sebastian <sebastian.selander@gmail.com>
Date: Sat, 1 Apr 2023 18:45:08 +0200
Subject: [PATCH] Disabled shadowing in pattern match with nice error message,
 added aux functions

---
 src/Auxiliary.hs       |  7 +++++++
 src/Renamer/Renamer.hs | 23 ++++++++++++++++++-----
 2 files changed, 25 insertions(+), 5 deletions(-)

diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs
index 0c9f012..b4972a7 100644
--- a/src/Auxiliary.hs
+++ b/src/Auxiliary.hs
@@ -46,3 +46,10 @@ char = TLit "Char"
 
 tupSequence :: Monad m => (m a, b) -> m (a, b)
 tupSequence (ma, b) = (,b) <$> ma
+
+fst_ :: (a, b, c) -> a
+snd_ :: (a, b, c) -> b
+trd_ :: (a, b, c) -> c
+snd_ (_, a, _) = a
+fst_ (a, _, _) = a
+trd_ (_, _, a) = a
diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs
index 48ec228..d30412f 100644
--- a/src/Renamer/Renamer.hs
+++ b/src/Renamer/Renamer.hs
@@ -5,23 +5,31 @@ module Renamer.Renamer (rename) where
 
 import Auxiliary (mapAccumM)
 import Control.Applicative (Applicative (liftA2))
+import Control.Monad (when)
 import Control.Monad.Except (
     ExceptT,
-    MonadError (throwError),
+    MonadError (catchError, throwError),
     runExceptT,
  )
 import Control.Monad.State (
     MonadState,
     State,
+    StateT,
     evalState,
+    evalStateT,
+    get,
     gets,
+    lift,
     mapAndUnzipM,
     modify,
+    put,
  )
 import Data.Function (on)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe)
+import Data.Set (Set)
+import Data.Set qualified as Set
 import Data.Tuple.Extra (dupe, second)
 import Grammar.Abs
 import Grammar.ErrM (Err)
@@ -134,17 +142,22 @@ renameBranches ns xs = do
     if null new_names then return (mempty, xs') else return (head new_names, xs')
 
 renameBranch :: Names -> Branch -> Rn (Names, Branch)
-renameBranch ns (Branch patt e) = do
-    (new_names, patt') <- renamePattern ns patt
+renameBranch ns b@(Branch patt e) = do
+    (new_names, patt') <- catchError (evalStateT (renamePattern ns patt) mempty) (\x -> throwError $ x ++ " in pattern '" ++ printTree b ++ "'")
     (new_names', e') <- renameExp new_names e
     return (new_names', Branch patt' e')
 
-renamePattern :: Names -> Pattern -> Rn (Names, Pattern)
+renamePattern :: Names -> Pattern -> StateT (Set LIdent) Rn (Names, Pattern)
 renamePattern ns p = case p of
     PInj cs ps -> do
         (ns_new, ps') <- mapAccumM renamePattern ns ps
         return (ns_new, PInj cs ps')
-    PVar name -> second PVar <$> newNameL ns name
+    PVar name -> do
+        vs <- get
+        when (name `Set.member` vs) (throwError $ "Conflicting definitions of '" ++ printTree name ++ "'")
+        put (Set.insert name vs)
+        nn <- lift $ newNameL ns name
+        return $ second PVar nn
     _ -> return (ns, p)
 
 renameTVars :: Type -> Rn Type