fixing the lock fields

src/compiler/api/GF/Compile/CheckGrammar.hs

@@ -33,6 +33,7 @@ import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
 import GF.Grammar
 import GF.Grammar.Lexer
 import GF.Grammar.Lookup
+import GF.Grammar.Lockfield
 
 import GF.Data.Operations
 import GF.Infra.CheckM
@@ -198,9 +199,9 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
 
     CncFun mty mt mpr mpmcfg -> do
       mt <- case (mty,mt) of
-              (Just (_,cat,cont,val),Just (L loc trm)) ->
+              (Just (args,cat,cont,val),Just (L loc trm)) ->
                   chIn loc "linearization of" $ do
-                     (trm,_) <- checkLType g trm (mkFunType (map (\(_,_,ty) -> ty) cont) val)  -- erases arg vars
+                     (trm,_) <- checkLType g trm (mkFunType (zipWith (\cat (_,_,ty) -> lock cat ty) args cont) val)  -- erases arg vars
                      return (Just (L loc (etaExpand [] trm cont)))
               _ -> return mt
       mpr  <- case mpr of

src/compiler/api/GF/Grammar/Lockfield.hs

@@ -14,29 +14,28 @@
 -- AR 8\/2\/2005 detached from 'compile/MkResource'
 -----------------------------------------------------------------------------
 
-module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
+module GF.Grammar.Lockfield (lock, lockLabel, isLockLabel) where
 
 import GF.Infra.Ident
+import GF.Grammar.Predef
 import GF.Grammar.Grammar
-import GF.Grammar.Macros
 
 import GF.Data.Operations(ErrorMonad,Err(..))
 
-lockRecType :: ErrorMonad m => Ident -> Type -> m Type
-lockRecType c t@(RecType rs) = 
-  let lab = lockLabel c in
-  return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]
-    then t --- don't add an extra copy of lock field, nor predef cats
-    else RecType (rs ++ [(lockLabel c,  RecType [])])
-lockRecType c t = plusRecType t $ RecType [(lockLabel c,  RecType [])]
-
-unlockRecord :: Monad m => Ident -> Term -> m Term
-unlockRecord c ft = do
-  let (xs,t) = termFormCnc ft
-  let lock = R [(lockLabel c,  (Just (RecType []),R []))]
-  case plusRecord t lock of
-    Ok t' -> return $ mkAbs xs t'
-    _ -> return $ mkAbs xs (ExtR t lock)
+lock :: Ident -> Term -> Term
+lock c t@(RecType rs) =
+  let lbl = lockLabel c
+  in if elem lbl (map fst rs) || elem c [cString,cInt]
+       then t --- don't add an extra copy of lock field, nor predef cats
+       else RecType (rs ++ [(lbl, RecType [])])
+lock c t@(R rs) =
+  let lbl = lockLabel c
+  in if elem lbl (map fst rs)
+       then t
+       else R (rs ++ [(lbl, (Just (RecType []),R []))])
+lock c (Abs b x t) = Abs b x (lock c t)
+lock c (FV ts)     = FV (map (lock c) ts)
+lock c t           = t
 
 lockLabel :: Ident -> Label
 lockLabel c = LIdent $! prefixRawIdent lockPrefix (ident2raw c)
@@ -46,5 +45,4 @@ isLockLabel l = case l of
   LIdent c -> isPrefixOf lockPrefix c
   _        -> False
 
-
 lockPrefix = rawIdentS "lock_"

src/compiler/api/GF/Grammar/Lookup.hs

@@ -45,10 +45,6 @@ import GF.Text.Pretty
 import qualified Data.Map as Map
 import qualified PGF2
 
--- whether lock fields are added in reuse
-lock c = lockRecType c -- return
-unlock c = unlockRecord c -- return
-
 -- to look up a constant etc in a search tree --- why here? AR 29/5/2008
 lookupIdent :: ErrorMonad m => Ident -> Map.Map Ident b -> m b
 lookupIdent c t =
@@ -101,7 +97,7 @@ lookupQIdentInfo gr (m,c) = do
 
 lookupResDef :: ErrorMonad m => Grammar -> QIdent -> m Term
 lookupResDef gr (m,c)
-  | isPredefCat c = lock c defLinType
+  | isPredefCat c = return (lock c defLinType)
   | otherwise     = look m c
   where
     look m c = do
@@ -109,10 +105,10 @@ lookupResDef gr (m,c)
       case info of
         ResOper _ (Just (L _ t)) -> return t
         ResOper _ Nothing  -> return (Q (m,c))
-        CncCat (Just (L _ ty)) _ _ _ _ -> lock c ty
-        CncCat _ _ _ _ _        -> lock c defLinType
+        CncCat (Just (L _ ty)) _ _ _ _ -> return (lock c ty)
+        CncCat _ _ _ _ _        -> return (lock c defLinType)
 
-        CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr
+        CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> return (lock cat tr)
         CncFun _                  (Just (L _ tr)) _ _ -> return tr
 
         AnyInd _ n        -> look n c
@@ -128,9 +124,8 @@ lookupResType gr (m,c) = do
 
     -- used in reused concrete
     CncCat _ _ _ _ _ -> return typeType
-    CncFun (Just (_,cat,cont,val)) _ _ _ -> do
-          val' <- lock cat val
-          return $ mkProd cont val' []
+    CncFun (Just (args,cat,cont,val)) _ _ _ ->
+           return $ (mkFunType (zipWith (\cat (_,_,ty) -> lock cat ty) args cont) (lock cat val))
     AnyInd _ n        -> lookupResType gr (n,c)
     ResParam _ _    -> return typePType
     ResValue (L _ t) _ -> return t
@@ -145,8 +140,7 @@ lookupOverloadTypes gr id@(m,c) = do
     -- used in reused concrete
     CncCat _ _ _ _ _ -> ret typeType
     CncFun (Just (_,cat,cont,val)) _ _ _ -> do
-          val' <- lock cat val
-          ret $ mkProd cont val' []
+          ret $ mkProd cont (lock cat val) []
     ResParam _ _    -> ret typePType
     ResValue (L _ t) _ -> ret t
     ResOverload os tysts -> do
@@ -265,13 +259,9 @@ allOpers gr =
       ResValue ltyp _           -> [ltyp]
       ResOverload _ tytrs       -> [ltyp | (ltyp,_) <- tytrs]
       CncFun  (Just (_,i,ctx,typ)) _ _ _ ->
-                                   [L NoLoc (mkProdSimple ctx (lock' i typ))]
+                                   [L NoLoc (mkProdSimple ctx (lock i typ))]
       _                         -> []
 
-    lock' i typ = case lock i typ of
-                    Ok t -> t
-                    _ -> typ
-
 --- not for dependent types
 allOpersTo :: Grammar -> Type -> [(QIdent,Type,Location)]
 allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where