fix renaming

src/Core/MatchMerge.hs

@@ -143,12 +143,12 @@ splitBranchConstructors' b@(Branch ps _) branches =
               (_, b') | isMatchAnyBranch b' -> Just b'
               _ -> Nothing -- no error branch
         -- Acumulated pattern and p'
-        patNew <- zipWithM (\acc p -> patternsMatch acc p) accP ps' 
+        patNew <- zipWithM (\acc p -> patternsMatch restTns acc p) accP ps' 
         let (newVars, patNews) = unzip patNew
         if not $ isSimpleMatches patNews then
           -- Restrict the pattern to the smallest that matches multiple branches
           -- Add the new branch to the list of branches that match partially
-          -- trace ("splitConstructors:\n" ++ show accP ++ "\nand\n" ++ show ps' ++ "\n have common superstructure:\n" ++ show patNew ++ "\n\n") $
+          -- trace ("splitConstructors:\n" ++ show accP ++ "\nand\n" ++ show ps' ++ "\n have common superstructure:\n" ++ show patNew ++ "\nwith discriminating variables: " ++ show newVars ++ "\n") $
             return (b':bs', bs2', newError, newAny, concat newVars, patNews)
           -- Didn't match the current branch, keep the old pattern
           -- Add the new branch to the list of branches that don't match any subpattern
@@ -193,25 +193,32 @@ generalErrorBranch b@(Branch p g) | isErrorBranch b = Branch [PatWild] g
 generalErrorBranch b = b
 
 -- Returns largest common pattern superstructure, with variables added where needed, and the distinguishing variables returned
-patternsMatch :: Pattern -> Pattern -> Unique ([TName], Pattern)
-patternsMatch p p'
-  = case (p, p') of
+patternsMatch :: [TName] -> Pattern -> Pattern -> Unique ([TName], Pattern)
+patternsMatch distinguishingVars p p' = 
+  let recur = patternsMatch distinguishingVars in
+    -- trace ("Common superstructure of " ++ (show $ vcat [text $ show p, text $ show p'])) $
+    case (p, p') of
     (PatLit l1, PatLit l2) -> 
       if l1 == l2 then return ([], p) -- Literals that match, just match the literal
       else do -- Match a variable of the literal's type
         name <- newVarName 
         let tn = TName name (typeOf l1)
         return ([tn], PatVar tn PatWild)
     (PatVar tn1 v1, PatVar tn2 v2) | tn1 == tn2 -> do 
-      -- Same pattern variable, reuse the variable name, but find common substructure 
-      (tns, sub) <- patternsMatch v1 v2
-      return (tns, PatVar tn1 sub)
+      -- Same pattern variable, can't reuse the variable name - because it could be a name representing another location in another pattern
+      name <- newVarName 
+      (tns, sub) <- recur v1 v2
+      let tn' = TName name (typeOf tn1)
+      let distinguished = tn1 `elem` distinguishingVars
+      return (tns ++ if distinguished then [tn'] else [], PatVar tn' sub)
     (PatVar tn1 v1, PatVar tn2 v2) -> do
       -- Variables that don't match name, but (should match types because of type checking)
       -- Create a common name to match for
       name <- newVarName 
-      (tns, sub) <- patternsMatch v1 v2
-      return (tns, PatVar (TName name (typeOf tn1)) sub)
+      (tns, sub) <- recur v1 v2
+      let distinguished = tn1 `elem` distinguishingVars
+      let tn' = TName name (typeOf tn1)
+      return (tns ++ if distinguished then [tn'] else [], PatVar tn' sub)
     (PatWild, PatWild) -> return ([], PatWild) -- Wilds match trivially
     (PatCon name1 patterns1 cr targs1 exists1 res1 ci sk, PatCon name2 patterns2 _ targs2 exists2 res2 _ _) -> 
       if -- Same constructor (name, and types) -- types should match due to type checking, but names could differ
@@ -221,7 +228,7 @@ patternsMatch p p'
         res1 == res2
       then do 
         -- Same constructor, match substructure
-        res <- zipWithM patternsMatch patterns1 patterns2
+        res <- zipWithM recur patterns1 patterns2
         let (subs, pats) = unzip res
         return (concat subs, PatCon name1 pats cr targs1 exists1 res1 ci sk)
       else do
@@ -237,10 +244,10 @@ patternsMatch p p'
     (_, PatVar tn PatWild) -> do
       return ([tn], PatVar tn PatWild)
     (PatVar tn pat, _) -> do
-      (tns, sub) <- patternsMatch pat p'
+      (tns, sub) <- recur pat p'
       return (tns, PatVar tn sub)
     (_, PatVar tn pat) -> do
-      (tns, sub) <- patternsMatch p pat
+      (tns, sub) <- recur p pat
       return (tns, PatVar tn sub)
     -- Double sided wilds already handled so we can safely request the type, as well as one sided vars
     (_, PatWild) -> do
@@ -263,8 +270,9 @@ patternType p = case p of
 -- Strip the outer constructors and propagate variable substitution into branch expressions
 stripOuterConstructors :: [TName] -> [Pattern] -> Branch -> Branch
 stripOuterConstructors discriminatingVars templates (Branch pts exprs) = 
-  -- trace ("Using template\n" ++ show templates ++"\n" ++ show pts ++ "\ngot:\n" ++ show (zip tns patNew) ++ "\n" ++ " with variable name mapping " ++ show replaceMap ++ "\n") $ 
-    Branch (concatMap (fromMaybe [PatWild]) patNew) $ map replaceInGuard exprs
+  -- trace ("Using template\n" ++ show templates ++"\n" ++ show pts ++ "\ngot:\n" ++ show discriminatingVars ++ "\n" ++ show patNew ++ "\n\n" ++ show (vcat (map (text . show) (zip discriminatingVars patNew))) ++ "\nWith variable name mapping:\n" ++ show replaceMap ++ "\n") $ 
+    assertion "Invalid subpattern match " (length patNew == length discriminatingVars) $
+    Branch patNew $ map replaceInGuard exprs
   where
     replaceInGuard (Guard tst expr)
       = Guard (rewriteBottomUp replaceInExpr tst) (rewriteBottomUp replaceInExpr expr)
@@ -275,13 +283,20 @@ stripOuterConstructors discriminatingVars templates (Branch pts exprs) =
             Just (Var name info) -> Var name info
             _ -> e
           e' -> e'
-    (patNew, replaceMaps) = unzip $ zipWith (getReplaceMap discriminatingVars) templates pts
+    (patsNew, replaceMaps) = unzip $ zipWith (getReplaceMap discriminatingVars) templates pts
+    patNew = concat patsNew
     replaceMap = concat replaceMaps
 
+getReplaceMap :: [TName] -> Pattern -> Pattern -> ([Pattern], [(TName, Expr)])
+getReplaceMap discriminatingVars template p' = 
+  case getReplaceMap' discriminatingVars template p' of
+    (Just pats, replacers) -> (pats, replacers)
+    (Nothing, replacers) -> error "Should never happen"
+
 -- Get the new pattern that differs from the old pattern and the subsitution map
-getReplaceMap :: [TName] -> Pattern -> Pattern -> (Maybe [Pattern], [(TName, Expr)])
-getReplaceMap discriminatingVars template p'
-  = let recur = getReplaceMap discriminatingVars in
+getReplaceMap' :: [TName] -> Pattern -> Pattern -> (Maybe [Pattern], [(TName, Expr)])
+getReplaceMap' discriminatingVars template p'
+  = let recur = getReplaceMap' discriminatingVars in
     case (template, p') of
     (PatLit l1, PatLit l2) -> (Nothing, [])
     (PatVar tn1 v1, PatVar tn2 v2) | tn1 == tn2 -> 
@@ -293,23 +308,26 @@ getReplaceMap discriminatingVars template p'
       let (pat', rp) = recur v1 v2
           -- introduce a new variable using the template's name, and map the other name to the template
           rp' = (tn2, Var tn1 InfoNone):rp in
+      -- trace (show pat' ++ show (tn1 `elem` discriminatingVars) ++ show tn1) $
       case pat' of 
         Nothing -> -- 
           -- Differs but doesn't discriminate
           if tn1 `notElem` discriminatingVars then (Nothing, rp') 
-
           else (Just [PatWild], rp') 
         Just _ -> -- Use the new pattern
           (pat', rp')
     (PatWild, PatWild) -> (Nothing, [])
     (PatCon name1 patterns1 cr targs1 exists1 res1 ci _, PatCon name2 patterns2 _ targs2 exists2 res2 _ sk) -> 
       let res = zipWith recur patterns1 patterns2 
           (patterns', replaceMaps) = unzip res
-          replaceMap = concat replaceMaps
-      in (Just (concatMap (fromMaybe []) patterns'), replaceMap)
+          replaceMap = concat replaceMaps in 
+      -- trace ("Subpats " ++ show (vcat (map (text . show) patterns')) ++ " " ++ show (length (concatMap (fromMaybe []) patterns'))) $
+      (Just (concatMap (fromMaybe []) patterns'), replaceMap)
     (PatVar tn PatWild, PatWild) -> 
       (if tn `notElem` discriminatingVars then Nothing else Just [PatWild], [])
-    (PatVar tn PatWild, pat2) -> (Just [pat2], [])
+    (PatVar tn PatWild, pat2) -> 
+      -- trace ("Here " ++ show discriminatingVars) $
+       (if tn `notElem` discriminatingVars then Nothing else Just [pat2], [])
     (PatVar tn pat, pat2) -> recur pat pat2
     (PatWild, pat2) -> (Just [pat2], [])
     -- (PatCon _ _ _ _ _ _ _ _, PatWild) -> (Just [template], [])