1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
----------------------------------------------------------------------
-- |
-- Module : Update
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.8 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Compile.Update (updateRes, buildAnyTree, combineAnyInfos, unifyAnyInfo,
-- * these auxiliaries should be somewhere else
-- since they don't use the info types
groupInfos, sortInfos, combineInfos, unifyInfos,
tryInsert, unifAbsDefs, unifConstrs
) where
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.PrGrammar
import GF.Infra.Modules
import GF.Data.Operations
import Data.List
import Control.Monad
-- | update a resource module by adding a new or changing an old definition
updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar
updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
upd (n,mod)
| n /= m = (n,mod)
| n == m = case mod of
ModMod r -> (m,ModMod $ updateModule r i info)
_ -> (n,mod) --- no error msg
-- | combine a list of definitions into a balanced binary search tree
buildAnyTree :: [(Ident,Info)] -> Err (BinTree Ident Info)
buildAnyTree ias = do
ias' <- combineAnyInfos ias
return $ buildTree ias'
-- | unifying information for abstract, resource, and concrete
combineAnyInfos :: [(Ident,Info)] -> Err [(Ident,Info)]
combineAnyInfos = combineInfos unifyAnyInfo
unifyAnyInfo :: Ident -> Info -> Info -> Err Info
unifyAnyInfo c i j = errIn ("combining information for" +++ prt c) $ case (i,j) of
(AbsCat mc1 mf1, AbsCat mc2 mf2) ->
liftM2 AbsCat (unifPerhaps mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs
(AbsFun mt1 md1, AbsFun mt2 md2) ->
liftM2 AbsFun (unifPerhaps mt1 mt2) (unifAbsDefs md1 md2) -- adding defs
(ResParam mt1, ResParam mt2) -> liftM ResParam $ unifPerhaps mt1 mt2
(ResOper mt1 m1, ResOper mt2 m2) ->
liftM2 ResOper (unifPerhaps mt1 mt2) (unifPerhaps m1 m2)
(CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) ->
liftM3 CncCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) (unifPerhaps mp1 mp2)
(CncFun m mt1 md1, CncFun _ mt2 md2) ->
liftM2 (CncFun m) (unifPerhaps mt1 mt2) (unifPerhaps md1 md2) ---- adding defs
-- for bw compatibility with unspecified printnames in old GF
(CncFun Nothing Nope (Yes pr),_) ->
unifyAnyInfo c (CncCat Nope Nope (Yes pr)) j
(_,CncFun Nothing Nope (Yes pr)) ->
unifyAnyInfo c i (CncCat Nope Nope (Yes pr))
_ -> Bad $ "cannot unify informations in" ++++ show i ++++ "and" ++++ show j
--- these auxiliaries should be somewhere else since they don't use the info types
groupInfos :: Eq a => [(a,b)] -> [[(a,b)]]
groupInfos = groupBy (\i j -> fst i == fst j)
sortInfos :: Ord a => [(a,b)] -> [(a,b)]
sortInfos = sortBy (\i j -> compare (fst i) (fst j))
combineInfos :: Ord a => (a -> b -> b -> Err b) -> [(a,b)] -> Err [(a,b)]
combineInfos f ris = do
let riss = groupInfos $ sortInfos ris
mapM (unifyInfos f) riss
unifyInfos :: (a -> b -> b -> Err b) -> [(a,b)] -> Err (a,b)
unifyInfos _ [] = Bad "empty info list"
unifyInfos unif ris = do
let c = fst $ head ris
let infos = map snd ris
let ([i],is) = splitAt 1 infos
info <- foldM (unif c) i is
return (c,info)
tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) ->
BinTree a b -> (a,b) -> Err (BinTree a b)
tryInsert unif indir tree z@(x, info) = case justLookupTree x tree of
Ok info0 -> do
info1 <- unif info info0
return $ updateTree (x,info1) tree
_ -> return $ updateTree (x,indir info) tree
{- ----
case tree of
NT -> return $ BT (x, indir info) NT NT
BT c@(a,info0) left right
| x < a -> do
left' <- tryInsert unif indir left z
return $ BT c left' right
| x > a -> do
right' <- tryInsert unif indir right z
return $ BT c left right'
| x == a -> do
info' <- unif info info0
return $ BT (x,info') left right
-}
--- addToMaybeList m c = maybe (return c) (\old -> return (c ++ old)) m
unifAbsDefs :: Perh Term -> Perh Term -> Err (Perh Term)
unifAbsDefs p1 p2 = case (p1,p2) of
(Nope, _) -> return p2
(_, Nope) -> return p1
(Yes (Eqs bs), Yes (Eqs ds)) -> return $ yes $ Eqs $ bs ++ ds --- order!
_ -> Bad "update conflict for definitions"
unifConstrs :: Perh [Term] -> Perh [Term] -> Err (Perh [Term])
unifConstrs p1 p2 = case (p1,p2) of
(Nope, _) -> return p2
(_, Nope) -> return p1
(Yes bs, Yes ds) -> return $ yes $ bs ++ ds
_ -> Bad "update conflict for constructors"
|
