record type extension freshness check

src/GF/Compile/CheckGrammar.hs

@@ -276,7 +276,7 @@ computeLType gr t = do
       r' <- comp r
       s' <- comp s
       case (r',s') of
-        (RecType rs, RecType ss) -> return $ RecType (rs ++ ss)
+        (RecType rs, RecType ss) -> checkErr $ plusRecType r' s'
         _ -> return $ ExtR r' s'
 
     _ | isPredefConstant ty -> return ty
@@ -414,9 +414,13 @@ inferLType gr trm = case trm of
      rT'     <- comp rT
      (s',sT) <- infer s
      sT'     <- comp sT
+
      let trm' = ExtR r' s'
+     ---- trm'    <- checkErr $ plusRecord r' s'
      case (rT', sT') of
-       (RecType rs, RecType ss) -> return (trm', RecType (rs ++ ss))
+       (RecType rs, RecType ss) -> do
+         rt <- checkErr $ plusRecType rT' sT'
+         return (trm', rt)
        _ | rT' == typeType && sT' == typeType -> return (trm', typeType)
        _ -> prtFail "records or record types expected in" trm
 

src/GF/Grammar/Compute.hs

@@ -86,17 +86,21 @@ computeTerm gr = comp where
        t' <- comp g t
        case t' of
          FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . FV
-         R r   -> maybe (prtBad "no value for label" l) (comp g . snd) $ lookup l r 
+         R r   -> maybe (prtBad "no value for label" l) (comp g . snd) $ 
+                    lookup l $ reverse r 
 
-         ExtR (R a) b ->                 -- NOT POSSIBLE both a and b records!
-           case comp g (P (R a) l) of
-             Ok v -> return v
-             _ -> comp g (P b l)
          ExtR a (R b) ->                 
            case comp g (P (R b) l) of
              Ok v -> return v
              _ -> comp g (P a l)
 
+--- { - --- this is incorrect, since b can contain the proper value
+         ExtR (R a) b ->                 -- NOT POSSIBLE both a and b records!
+           case comp g (P (R a) l) of
+             Ok v -> return v
+             _ -> comp g (P b l)
+--- - } ---
+
          Alias _ _ r -> comp g (P r l)
 
          S (T i cs) e -> prawitz g i (flip P l) cs e
@@ -207,8 +211,8 @@ computeTerm gr = comp where
          (Alias _ _ d, _)  -> comp g $ ExtR d s'
          (_, Alias _ _ d)  -> comp g $ Glue r' d
 
-         (R rs, R ss) -> return $ R (rs ++ ss)
+         (R rs, R ss) -> plusRecord r' s'
-         (RecType rs, RecType ss) -> return $ RecType (rs ++ ss)
+         (RecType rs, RecType ss) -> plusRecType r' s'
          _ -> return $ ExtR r' s'
 
      -- case-expand tables

src/GF/Grammar/Lockfield.hs

@@ -24,6 +24,11 @@ import Operations
 -- AR 8/2/2005 detached from compile/MkResource
 
 lockRecType :: Ident -> Type -> Err Type
+lockRecType c t@(RecType rs) = 
+  let lab = lockLabel c in
+  return $ if elem lab (map fst rs) 
+    then t --- don't add an extra copy of the lock field
+    else RecType (rs ++ [(lockLabel c,  RecType [])])
 lockRecType c t = plusRecType t $ RecType [(lockLabel c,  RecType [])]
 
 unlockRecord :: Ident -> Term -> Err Term

src/GF/Grammar/Macros.hs

@@ -339,13 +339,17 @@ mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt], t, []) -- nondep prod
 
 plusRecType :: Type -> Type -> Err Type
 plusRecType t1 t2 = case (unComputed t1, unComputed t2) of
-  (RecType r1, RecType r2) -> return (RecType (r1 ++ r2))
+  (RecType r1, RecType r2) -> case
+    filter (`elem` (map fst r1)) (map fst r2) of
+      [] -> return (RecType (r1 ++ r2))
+      ls -> Bad $ "clashing labels" +++ unwords (map prt ls)
   _ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt t2) 
 
 plusRecord :: Term -> Term -> Err Term
 plusRecord t1 t2 =
  case (t1,t2) of
-   (R r1, R r2 ) -> return (R (r1 ++ r2))
+   (R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
+                              (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
    (_,    FV rs) -> mapM (plusRecord t1) rs >>= return . FV
    (FV rs,_    ) -> mapM (`plusRecord` t2) rs >>= return . FV
    _ -> Bad ("cannot add records" +++ prt t1 +++ "and" +++ prt t2)