From bf5dfb2293e6cf3e6787742e9402052d8fed2a5d Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Mon, 9 Sep 2013 19:52:08 +0000
Subject: [PATCH] Nonlinear patterns in concrete syntax are now detected and
 reported as errors

Before, they were silently converted to linear patterns.
Nonlinear patterns in MorphoCat.gf, ParadigmsGre.gf and ParadigmsFin.gf have
been make linear by renaming pattern variables.
---
 src/compiler/GF/Compile/Rename.hs | 122 +++++++++++++++---------------
 1 file changed, 63 insertions(+), 59 deletions(-)

diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index 9e959c353..6031ab938 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -39,7 +39,7 @@ import GF.Grammar.Printer
 import GF.Data.Operations
 
 import Control.Monad
-import Data.List (nub)
+import Data.List (nub,(\\))
 import Text.PrettyPrint
 
 -- | this gives top-level access to renaming term input in the cc command
@@ -235,76 +235,80 @@ renameTerm env vars = ren vars where
 
 -- | vars not needed in env, since patterns always overshadow old vars
 renamePattern :: Status -> Patt -> Check (Patt,[Ident])
-renamePattern env patt = case patt of
+renamePattern env patt =
+    do r@(p',vs) <- renp patt
+       let dupl = vs \\ nub vs
+       unless (null dupl) $ checkError (hang (text "[C.4.13] Pattern is not linear:") 4
+                                             (ppPatt Unqualified 0 patt))
+       return r
+  where
+    renp patt = case patt of
+      PMacro c -> do
+        c' <- renid $ Vr c
+        case c' of
+          Q d -> renp $ PM d
+          _ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt)
 
-  PMacro c -> do
-    c' <- renid $ Vr c
-    case c' of
-      Q d -> renp $ PM d
-      _ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt)
+      PC c ps -> do
+        c' <- renid $ Cn c
+        case c' of
+          QC c -> do psvss <- mapM renp ps
+                     let (ps,vs) = unzip psvss
+                     return (PP c ps, concat vs)
+          Q  _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead")
+          _    -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c')
 
-  PC c ps -> do
-    c' <- renid $ Cn c
-    case c' of
-      QC c -> do psvss <- mapM renp ps
-                 let (ps,vs) = unzip psvss
-                 return (PP c ps, concat vs)
-      Q  _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead")
-      _    -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c')
+      PP c ps -> do
+        (QC c') <- renid (QC c)
+        psvss <- mapM renp ps
+        let (ps',vs) = unzip psvss
+        return (PP c' ps', concat vs)
 
-  PP c ps -> do
-    (QC c') <- renid (QC c)
-    psvss <- mapM renp ps
-    let (ps',vs) = unzip psvss
-    return (PP c' ps', concat vs)
+      PM c -> do
+        x <- renid (Q c)
+        c' <- case x of
+                (Q c') -> return c'
+                _      -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt)
+        return (PM c', [])
 
-  PM c -> do
-    x <- renid (Q c)
-    c' <- case x of
-            (Q c') -> return c'
-            _      -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt)
-    return (PM c', [])
+      PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of
+                                                 QC c -> return (PP c [],[])
+                                                 _    -> checkError (text "not a constructor")
+                     , return (patt, [x])
+                     ]
 
-  PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of
-                                             QC c -> return (PP c [],[])
-                                             _    -> checkError (text "not a constructor")
-                 , return (patt, [x])
-                 ]
+      PR r -> do
+        let (ls,ps) = unzip r
+        psvss <- mapM renp ps
+        let (ps',vs') = unzip psvss
+        return (PR (zip ls ps'), concat vs')
 
-  PR r -> do
-    let (ls,ps) = unzip r
-    psvss <- mapM renp ps
-    let (ps',vs') = unzip psvss
-    return (PR (zip ls ps'), concat vs') 
+      PAlt p q -> do
+        (p',vs) <- renp p
+        (q',ws) <- renp q
+        return (PAlt p' q', vs ++ ws)
 
-  PAlt p q -> do
-    (p',vs) <- renp p
-    (q',ws) <- renp q
-    return (PAlt p' q', vs ++ ws)
+      PSeq p q -> do
+        (p',vs) <- renp p
+        (q',ws) <- renp q
+        return (PSeq p' q', vs ++ ws)
 
-  PSeq p q -> do
-    (p',vs) <- renp p
-    (q',ws) <- renp q
-    return (PSeq p' q', vs ++ ws)
+      PRep p -> do
+        (p',vs) <- renp p
+        return (PRep p', vs)
 
-  PRep p -> do
-    (p',vs) <- renp p
-    return (PRep p', vs)
+      PNeg p -> do
+        (p',vs) <- renp p
+        return (PNeg p', vs)
 
-  PNeg p -> do
-    (p',vs) <- renp p
-    return (PNeg p', vs)
+      PAs x p -> do
+        (p',vs) <- renp p
+        return (PAs x p', x:vs)
 
-  PAs x p -> do
-    (p',vs) <- renp p
-    return (PAs x p', x:vs)
+      _ -> return (patt,[])
 
-  _ -> return (patt,[])
-
- where 
-   renp  = renamePattern env
-   renid = renameIdentTerm env
-   renid' = renameIdentTerm' env
+    renid = renameIdentTerm env
+    renid' = renameIdentTerm' env
 
 renameContext :: Status -> Context -> Check Context
 renameContext b = renc [] where