GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-22 19:22:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

overload checking and messages; resource.txt modifs

Browse Source
This commit is contained in:
aarne
2007-05-31 09:58:38 +00:00
parent 93b4888b78
commit 76268417db
2 changed files with 106 additions and 75 deletions
Download Patch File Download Diff File Expand all files Collapse all files

25
src/GF/Compile/CheckGrammar.hs
View File

@@ -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