type checking pattern bindings

2 files changed, 19 insertions, 8 deletions

diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index c55873409..1daf4fd62 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -697,16 +697,26 @@ pattContext env typ p = case p of
     g <- pattContext env typ p
     return $ (x,typ):g
 
-  PAlt p q -> do
-    g1 <- pattContext env typ p
+  PAlt p' q -> do
+    g1 <- pattContext env typ p'
     g2 <- pattContext env typ q
-    return $ filter (flip elem g1) g2 -- must be in both
+    let pts = [pt | pt <- g1, notElem pt g2] ++ [pt | pt <- g2, notElem pt g1]
+    checkCond 
+      ("incompatible bindings of" +++ 
+       unwords (nub (map (prt . fst) pts))+++ 
+       "in pattern alterantives" +++ prt p) (null pts) 
+    return g1 -- must be g1 == g2
   PSeq p q -> do
     g1 <- pattContext env typ p
     g2 <- pattContext env typ q
     return $ g1 ++ g2
-  PRep p -> pattContext env typeStr p
-  PNeg p -> pattContext env typeStr p
+  PRep p' -> do
+    co <- pattContext env typeStr p'
+    if not (null co)
+      then checkWarn ("no variable bound inside * pattern" +++ prt p) 
+           >> return []
+      else return []
+  PNeg p' -> pattContext env typ p'
 
   _ -> return [] ---- check types!
  where 
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
index c7205dcaf..7635e6fa1 100644
--- a/src/GF/Grammar/PatternMatch.hs
+++ b/src/GF/Grammar/PatternMatch.hs
@@ -105,9 +105,10 @@ tryMatch (p,t) = do
          return (concat matches)
 
       (PRep p1, ([],K s, [])) -> checks [
-        trym (foldr (const (PSeq p1)) (PString "") [1..n]) t' | n <- [0 .. length s]
-        ]
-
+         trym (foldr (const (PSeq p1)) (PString "") 
+           [1..n]) t' | n <- [0 .. length s]
+        ] >>
+        return []
       _ -> prtBad "no match in case expr for" t
   
 isInConstantForm :: Term -> Bool