From 76268417db7dc617aaaae0214b0515d990a5c471 Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Thu, 31 May 2007 09:58:38 +0000
Subject: overload checking and messages; resource.txt modifs

---
 src/GF/Compile/CheckGrammar.hs | 25 ++++++++++++++++++++++---
 1 file changed, 22 insertions(+), 3 deletions(-)

(limited to 'src')

diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index 262980eb9..85da644c8 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -380,6 +380,12 @@ inferLType gr trm = case trm of
    Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
 
    Q m ident -> checks [
+----     do
+----       over <- getOverload gr Nothing trm
+----       case over of
+----         Just trty -> return trty
+----         _ -> fail "not overloaded"
+----     ,
      termWith trm $ checkErr (lookupResType gr m ident) >>= comp
      ,
      checkErr (lookupResDef gr m ident) >>= infer
@@ -605,12 +611,13 @@ getOverload env@gr mt t = case appForm t of
      let (tts,tys) = unzip ttys
      let vfs = lookupOverloadInstance tys typs
 
-     case [vf | vf@(v,f) <- vfs, elem mt [Nothing,Just v]] of
+     case [vf | vf@(v,f) <- vfs, matchVal mt v] of
        [(val,fun)] -> return (mkApp fun tts, val)
        [] -> raise $ "no overload instance of" +++ prt f +++ 
-         maybe [] (("when expecting" +++) . prtType env) mt +++
          "for" +++ unwords (map (prtType env) tys) +++ "among" ++++ 
-         unlines [unwords (map (prtType env) ty) | (ty,_) <- typs]
+         unlines ["  " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++
+         maybe [] (("with value type" +++) . prtType env) mt
+
       ----  ++++ "DEBUG" +++ unwords (map show tys) +++ ";" 
       ----  ++++ unlines (map (show . fst) typs) ----
 
@@ -625,6 +632,10 @@ getOverload env@gr mt t = case appForm t of
            "for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++ 
            unlines [prtType env ty | (ty,_) <- vfs']
 
+   matchVal mt v = elem mt ([Nothing,Just v] ++ unlocked) where
+     unlocked = case v of
+       RecType fs -> [Just $ RecType $ filter (not . isLockLabel . fst) fs]
+       _ -> []
    ---- TODO: accept subtypes
    ---- TODO: use a trie
    lookupOverloadInstance tys typs = 
@@ -667,6 +678,14 @@ checkLType env trm typ0 = do
           (trm',ty') <- infer trm
           termWith trm' $ checkEq typ ty' trm'
 
+    Q _ _ -> do
+       over <- getOverload env (Just typ) trm
+       case over of
+         Just trty -> return trty
+         _ -> do
+          (trm',ty') <- infer trm
+          termWith trm' $ checkEq typ ty' trm'
+
     T _ [] ->
       prtFail "found empty table in type" typ
     T _ cs -> case typ of 
-- 
cgit v1.2.3