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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/01 09:53:19 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.7 $
--
-- Calculating the finiteness of each type in a grammar
-----------------------------------------------------------------------------
module GF.Conversion.SimpleToFinite
(convertGrammar) where
import GF.System.Tracing
import GF.Infra.Print
import GF.Formalism.GCFG
import GF.Formalism.SimpleGFC
import GF.Formalism.Utilities
import GF.Conversion.Types
import GF.Data.SortedList
import GF.Data.Assoc
import GF.Data.BacktrackM
import GF.Data.Utilities (lookupList)
import GF.Infra.Ident (Ident(..))
type CnvMonad a = BacktrackM () a
convertGrammar :: SGrammar -> SGrammar
convertGrammar rules = tracePrt "SimpleToFinie - nr. 'finite' rules" (prt . length) $
solutions cnvMonad ()
where split = calcSplitable rules
cnvMonad = member rules >>= convertRule split
convertRule :: Splitable -> SRule -> CnvMonad SRule
convertRule split (Rule abs cnc)
= do newAbs <- convertAbstract split abs
return $ Rule newAbs cnc
{-
-- old code
convertAbstract :: Splitable -> Abstract SDecl Name
-> CnvMonad (Abstract SDecl Name)
convertAbstract split (Abs decl decls name)
= case splitableFun split (name2fun name) of
Just cat' -> return $ Abs (Decl anyVar (mergeFun (name2fun name) cat') []) decls name
Nothing -> expandTyping split name [] decl decls []
expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SDecl -> [SDecl] -> [SDecl]
-> CnvMonad (Abstract SDecl Name)
expandTyping split name env (Decl x cat args) [] decls
= return $ Abs decl (reverse decls) name
where decl = substArgs split x env cat args []
expandTyping split name env typ (Decl x xcat xargs : declsToDo) declsDone
= do (x', xcat', env') <- calcNewEnv
let decl = substArgs split x' env xcat' xargs []
expandTyping split name env' typ declsToDo (decl : declsDone)
where calcNewEnv = case splitableCat split xcat of
Just newFuns -> do newFun <- member newFuns
let newCat = mergeFun newFun xcat
-- Just newCats -> do newCat <- member newCats
return (anyVar, newCat, (x,newCat) : env)
Nothing -> return (x, xcat, env)
-}
-- new code
convertAbstract :: Splitable -> Abstract SDecl Name
-> CnvMonad (Abstract SDecl Name)
convertAbstract split (Abs decl decls name)
= case splitableFun split fun of
Just cat' -> return $ Abs (Decl anyVar ([] ::--> (mergeFun fun cat' ::@ []))) decls name
Nothing -> expandTyping split [] fun profiles [] decl decls []
where Name fun profiles = name
expandTyping :: Splitable -> [(Var, SCat)]
-> Fun -> [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)]
-> SDecl -> [SDecl] -> [SDecl]
-> CnvMonad (Abstract SDecl Name)
expandTyping split env fun [] profiles (Decl x (typargs ::--> (cat ::@ args))) [] decls
= return $ Abs decl (reverse decls) (Name fun (reverse profiles))
where decl = substArgs split x env typargs cat args []
expandTyping split env fun (prof:profiles) profsDone typ
(Decl x (xtypargs ::--> (xcat ::@ xargs)) : declsToDo) declsDone
= do (x', xcat', env', prof') <- calcNewEnv
let decl = substArgs split x' env xtypargs xcat' xargs []
expandTyping split env' fun profiles (prof' : profsDone) typ declsToDo (decl : declsDone)
where calcNewEnv = case splitableCat split xcat of
Nothing -> return (x, xcat, env, prof)
Just newFuns -> do newFun <- member newFuns
let newCat = mergeFun newFun xcat
newProf = Constant (FNode newFun [[]])
-- should really be using some kind of
-- "profile unification"
return (anyVar, newCat, (x,newCat) : env, newProf)
substArgs :: Splitable -> Var -> [(Var, SCat)] -> [FOType SCat]
-> SCat -> [TTerm] -> [TTerm] -> SDecl
substArgs split x env typargs cat [] args = Decl x (typargs ::--> (cat ::@ reverse args))
substArgs split x env typargs cat (arg:argsToDo) argsDone
= case argLookup split env arg of
Just newCat -> substArgs split x env typargs (mergeArg cat newCat) argsToDo argsDone
Nothing -> substArgs split x env typargs cat argsToDo (arg : argsDone)
argLookup split env (TVar x) = lookup x env
argLookup split env (con :@ _) = fmap (mergeFun fun) (splitableFun split fun)
where fun = constr2fun con
----------------------------------------------------------------------
-- splitable categories (finite, no dependencies)
-- they should also be used as some dependency
type Splitable = (Assoc SCat [Fun], Assoc Fun SCat)
splitableCat :: Splitable -> SCat -> Maybe [Fun]
splitableCat = lookupAssoc . fst
splitableFun :: Splitable -> Fun -> Maybe SCat
splitableFun = lookupAssoc . snd
calcSplitable :: [SRule] -> Splitable
calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat)
where splitableCat2Funs = groupPairs $ nubsort splitableCatFuns
splitableFun2Cat = nubsort
[ (fun, cat) | (cat, fun) <- splitableCatFuns ]
-- cat-fun pairs that are splitable
splitableCatFuns = tracePrt "SimpleToFinite - splitable functions" prt $
[ (cat, name2fun name) |
Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] name) _ <- rules,
splitableCats ?= cat ]
-- all cats that are splitable
splitableCats = listSet $
tracePrt "SimpleToFinite - finite categories to split" prt $
(nondepCats <**> depCats) <\\> resultCats
-- all result cats for some pure function
resultCats = tracePrt "SimpleToFinite - result cats" prt $
nubsort [ cat | Rule (Abs (Decl _ (_ ::--> (cat ::@ _))) decls _) _ <- rules,
not (null decls) ]
-- all cats in constants without dependencies
nondepCats = tracePrt "SimpleToFinite - nondep cats" prt $
nubsort [ cat | Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] _) _ <- rules ]
-- all cats occurring as some dependency of another cat
depCats = tracePrt "SimpleToFinite - dep cats" prt $
nubsort [ cat | Rule (Abs decl decls _) _ <- rules,
cat <- varCats [] (decls ++ [decl]) ]
varCats _ [] = []
varCats env (Decl x (xargs ::--> xtyp@(xcat ::@ _)) : decls)
= varCats ((x,xcat) : env) decls ++
[ cat | (_::@args) <- (xtyp:xargs), arg <- args,
y <- varsInTTerm arg, cat <- lookupList y env ]
----------------------------------------------------------------------
-- utilities
-- mergeing categories
mergeCats :: String -> String -> String -> SCat -> SCat -> SCat
mergeCats before middle after (IC cat) (IC arg)
= IC (before ++ cat ++ middle ++ arg ++ after)
mergeFun, mergeArg :: SCat -> SCat -> SCat
mergeFun = mergeCats "{" ":" "}"
mergeArg = mergeCats "" "" ""
|
