msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

bugfix in record subtyping checking

Browse Source
This commit is contained in:
krasimir
2017-03-07 17:53:56 +00:00
parent 5ec43f2f75
commit 2e5499ba97
1 changed files with 7 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -63,7 +63,7 @@ tcRho ge scope t@(Q id) mb_ty =
runTcA (tcOverloadFailed t) $ runTcA (tcOverloadFailed t) $
tcApp ge scope t `bindTcA` \(t,ty) -> tcApp ge scope t `bindTcA` \(t,ty) ->
instSigma ge scope t ty mb_ty instSigma ge scope t ty mb_ty
tcRho ge scope t@(QC id) mb_ty = tcRho ge scope t@(QC id) mb_ty =
runTcA (tcOverloadFailed t) $ runTcA (tcOverloadFailed t) $
tcApp ge scope t `bindTcA` \(t,ty) -> tcApp ge scope t `bindTcA` \(t,ty) ->
instSigma ge scope t ty mb_ty instSigma ge scope t ty mb_ty
@@ -476,7 +476,12 @@ subsCheckRho ge scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do -- Rule
return (l, (mb_ty,t)) return (l, (mb_ty,t))
(scope,mkProj,mkWrap) <- mkAccess scope t (scope,mkProj,mkWrap) <- mkAccess scope t
rs <- sequence [mkField scope l t ty1 ty2 | (l,ty2) <- rs2, Just ty1 <- [lookup l rs1], Just t <- [mkProj l]]
let fields = [(l,ty2,lookup l rs1) | (l,ty2) <- rs2]
case [l | (l,_,Nothing) <- fields] of
[] -> return ()
missing -> tcError ("Missing fields:" <+> hsep missing)
rs <- sequence [mkField scope l t ty1 ty2 | (l,ty2,Just ty1) <- fields, Just t <- [mkProj l]]
return (mkWrap (R rs)) return (mkWrap (R rs))
subsCheckRho ge scope t tau1 tau2 = do -- Rule EQ subsCheckRho ge scope t tau1 tau2 = do -- Rule EQ
unify ge scope tau1 tau2 -- Revert to ordinary unification unify ge scope tau1 tau2 -- Revert to ordinary unification