diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GF/Compile/CheckGrammar.hs | 8 | ||||
| -rw-r--r-- | src/GF/Grammar/Compute.hs | 18 | ||||
| -rw-r--r-- | src/GF/Grammar/Lockfield.hs | 5 | ||||
| -rw-r--r-- | src/GF/Grammar/Macros.hs | 8 |
4 files changed, 28 insertions, 11 deletions
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index eef7a14d9..f4f1ccd40 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/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 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) |