record type extension freshness check

3 files changed, 22 insertions, 9 deletions

diff --git a/src/GF/Grammar/Compute.hs b/src/GF/Grammar/Compute.hs
index 2ddce3a6c..643621119 100644
--- a/src/GF/Grammar/Compute.hs
+++ b/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)
-         (RecType rs, RecType ss) -> return $ RecType (rs ++ ss)
+         (R rs, R ss) -> plusRecord r' s'
+         (RecType rs, RecType ss) -> plusRecType r' s'
          _ -> return $ ExtR r' s'
 
      -- case-expand tables
diff --git a/src/GF/Grammar/Lockfield.hs b/src/GF/Grammar/Lockfield.hs
index 3cdfdaa54..f283dde93 100644
--- a/src/GF/Grammar/Lockfield.hs
+++ b/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
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index cfc71b1a5..cb4dcc526 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/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)