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

Add type info to "Warning: ignoring lock fields in resolving..."

Browse Source
This commit is contained in:
hallgren
2012-09-06 13:15:48 +00:00
parent 5c1183ebc8
commit 95b372b281
1 changed files with 12 additions and 8 deletions
Download Patch File Download Diff File Expand all files Collapse all files

20
src/compiler/GF/Compile/TypeCheck/Concrete.hs
View File

@@ -314,15 +314,19 @@ getOverload gr g mt ot = case appForm ot of
matchOverload f typs ttys = do matchOverload f typs ttys = do
let (tts,tys) = unzip ttys let (tts,tys) = unzip ttys
let vfs = lookupOverloadInstance tys typs let vfs = lookupOverloadInstance tys typs
let matches = [vf | vf@((v,_),_) <- vfs, matchVal mt v] let matches = [vf | vf@((_,v,_),_) <- vfs, matchVal mt v]
let showTypes ty = hsep (map ppType ty)
case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
([(val,fun)],_) -> return (mkApp fun tts, val) ([(_,val,fun)],_) -> return (mkApp fun tts, val)
([],[(val,fun)]) -> do ([],[(pre,val,fun)]) -> do
checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) checkWarn $ text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
text "for" $$
nest 2 (showTypes tys) $$
text "using" $$
nest 2 (showTypes pre)
return (mkApp fun tts, val) return (mkApp fun tts, val)
([],[]) -> do ([],[]) -> do
let showTypes ty = hsep (map ppType ty)
checkError $ text "no overload instance of" <+> ppTerm Unqualified 0 f $$ checkError $ text "no overload instance of" <+> ppTerm Unqualified 0 f $$
text "for" $$ text "for" $$
nest 2 (showTypes tys) $$ nest 2 (showTypes tys) $$
@@ -346,7 +350,7 @@ getOverload gr g mt ot = case appForm ot of
_ -> checkError $ text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+> _ -> checkError $ text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
text "for" <+> hsep (map ppType tys) $$ text "for" <+> hsep (map ppType tys) $$
text "with alternatives" $$ text "with alternatives" $$
nest 2 (vcat [ppType ty | (ty,_) <- if null vfs1 then vfs2 else vfs2]) nest 2 (vcat [ppType ty | (_,ty,_) <- if null vfs1 then vfs2 else vfs2])
matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)] matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]
@@ -356,7 +360,7 @@ getOverload gr g mt ot = case appForm ot of
---- TODO: accept subtypes ---- TODO: accept subtypes
---- TODO: use a trie ---- TODO: use a trie
lookupOverloadInstance tys typs = lookupOverloadInstance tys typs =
[((mkFunType rest val, t),isExact) | [((pre,mkFunType rest val, t),isExact) |
let lt = length tys, let lt = length tys,
(ty,(val,t)) <- typs, length ty >= lt, (ty,(val,t)) <- typs, length ty >= lt,
let (pre,rest) = splitAt lt ty, let (pre,rest) = splitAt lt ty,
@@ -364,7 +368,7 @@ getOverload gr g mt ot = case appForm ot of
isExact || map unlocked pre == map unlocked tys isExact || map unlocked pre == map unlocked tys
] ]
noProds vfs = [(v,f) | (v,f) <- vfs, noProd v] noProds vfs = [(v,f) | (_,v,f) <- vfs, noProd v]
noProd ty = case ty of noProd ty = case ty of
Prod _ _ _ _ -> False Prod _ _ _ _ -> False