GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-24 18:28:55 -06:00
Code Issues Packages Projects Releases Wiki Activity

fix the update of overloaded functions

Browse Source
This commit is contained in:
krasimir
2009-03-05 19:18:51 +00:00
parent 7e75015e7d
commit 55dbaaa402
1 changed files with 4 additions and 4 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
src/GF/Compile/Update.hs
View File

@@ -35,7 +35,7 @@ buildAnyTree m = go Map.empty
go map [] = return map go map [] = return map
go map ((c,j):is) = do go map ((c,j):is) = do
case Map.lookup c map of case Map.lookup c map of
Just i -> case unifyAnyInfo c i j of Just i -> case unifyAnyInfo m i j of
Ok k -> go (Map.insert c k map) is Ok k -> go (Map.insert c k map) is
Bad _ -> fail $ render (text "cannot unify the informations" $$ Bad _ -> fail $ render (text "cannot unify the informations" $$
nest 4 (ppJudgement Qualified (c,i)) $$ nest 4 (ppJudgement Qualified (c,i)) $$
@@ -141,7 +141,7 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
try new (c,i) try new (c,i)
| not (cond c) = return new | not (cond c) = return new
| otherwise = case Map.lookup c new of | otherwise = case Map.lookup c new of
Just j -> case unifyAnyInfo c i j of Just j -> case unifyAnyInfo name i j of
Ok k -> return $ updateTree (c,k) new Ok k -> return $ updateTree (c,k) new
Bad _ -> do (base,j) <- case j of Bad _ -> do (base,j) <- case j of
AnyInd _ m -> lookupOrigInfo gr m c AnyInd _ m -> lookupOrigInfo gr m c
@@ -168,7 +168,7 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
_ -> (False,n) ---- canonical in Abs _ -> (False,n) ---- canonical in Abs
unifyAnyInfo :: Ident -> Info -> Info -> Err Info unifyAnyInfo :: Ident -> Info -> Info -> Err Info
unifyAnyInfo c i j = case (i,j) of unifyAnyInfo m i j = case (i,j) of
(AbsCat mc1 mf1, AbsCat mc2 mf2) -> (AbsCat mc1 mf1, AbsCat mc2 mf2) ->
liftM2 AbsCat (unifMaybe mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs liftM2 AbsCat (unifMaybe mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs
(AbsFun mt1 md1, AbsFun mt2 md2) -> (AbsFun mt1 md1, AbsFun mt2 md2) ->
@@ -177,7 +177,7 @@ unifyAnyInfo c i j = case (i,j) of
(ResParam mt1, ResParam mt2) -> liftM ResParam $ unifMaybe mt1 mt2 (ResParam mt1, ResParam mt2) -> liftM ResParam $ unifMaybe mt1 mt2
(ResValue mt1, ResValue mt2) -> (ResValue mt1, ResValue mt2) ->
liftM ResValue $ unifMaybe mt1 mt2 liftM ResValue $ unifMaybe mt1 mt2
(_, ResOverload ms t) | elem c ms -> (_, ResOverload ms t) | elem m ms ->
return $ ResOverload ms t return $ ResOverload ms t
(ResOper mt1 m1, ResOper mt2 m2) -> (ResOper mt1 m1, ResOper mt2 m2) ->
liftM2 ResOper (unifMaybe mt1 mt2) (unifMaybe m1 m2) liftM2 ResOper (unifMaybe mt1 mt2) (unifMaybe m1 m2)