From d1dc04747bbcd198379449f96759488d57ade386 Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Sun, 18 Jun 2006 19:23:00 +0000
Subject: [PATCH] restored lock fields with a clearer warning

---
 src/GF/Compile/CheckGrammar.hs |  6 +++---
 src/GF/Grammar/Lookup.hs       | 12 ++++++++----
 2 files changed, 11 insertions(+), 7 deletions(-)

diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index d01d2b097..0359c0679 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -771,12 +771,12 @@ checkEqLType env t u trm = do
   case t' == u' || alpha [] t' u' of
     True -> return t'
     -- forgive missing lock fields by only generating a warning.
-    --- better: use a flag to forgive (AR 31/1/2006)
+    --- better: use a flag to forgive? (AR 31/1/2006)
     _ -> case missingLock [] t' u' of
       Ok lo -> do
-        checkWarn $ "missing lock field" +++ unwords (map prt lo)
+        checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo)
         return t'
-      Bad s -> raise (s ++ "type of" +++ prt trm +++ 
+      Bad s -> raise (s +++ "type of" +++ prt trm +++ 
                 ": expected" ++++ prt t' ++++ "inferred" ++++ prt u')
  where
 
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
index 630b9c204..337329d44 100644
--- a/src/GF/Grammar/Lookup.hs
+++ b/src/GF/Grammar/Lookup.hs
@@ -33,6 +33,10 @@ import GF.Grammar.Lockfield
 import Data.List (nub)
 import Control.Monad
 
+-- whether lock fields are added in reuse
+lock c = lockRecType c -- return
+unlock c = unlockRecord c -- return
+
 lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term
 lookupResDef gr m c = look True m c where 
   look isTop m c = do
@@ -45,9 +49,9 @@ lookupResDef gr m c = look True m c where
           ResOper _ Nope    -> return (Q m c) ---- if isTop then lookExt m c 
                                  ---- else prtBad "cannot find in exts" c 
 
-          CncCat (Yes ty) _ _ -> return ty ---- lockRecType c $ ty
-          CncCat _ _ _        -> return defLinType ---- lockRecType c $ defLinType
-          CncFun _ (Yes tr) _ -> return tr ---- unlockRecord c tr
+          CncCat (Yes ty) _ _ -> lock c ty
+          CncCat _ _ _        -> lock c defLinType
+          CncFun _ (Yes tr) _ -> unlock c tr
 
           AnyInd _ n        -> look False n c
           ResParam _        -> return $ QC m c
@@ -70,7 +74,7 @@ lookupResType gr m c = do
         -- used in reused concrete
         CncCat _ _ _ -> return typeType
         CncFun (Just (cat,(cont,val))) _ _ -> do
-          val' <- return val ---- lockRecType cat val 
+          val' <- lock cat val 
           return $ mkProd (cont, val', [])
         CncFun _ _ _      -> lookFunType m m c
         AnyInd _ n        -> lookupResType gr n c