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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
|
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/11 13:52:52 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.1 $
--
-- Calculating the finiteness of each type in a grammar
-----------------------------------------------------------------------------
module GF.OldParsing.ConvertFiniteGFC where
import Operations
import GFC
import MkGFC
import AbsGFC
import Ident (Ident(..))
import GF.System.Tracing
import GF.Printing.PrintParser
import GF.Printing.PrintSimplifiedTerm
import GF.Data.SortedList
import GF.Data.Assoc
import GF.Data.BacktrackM
type Cat = Ident
type Name = Ident
type CnvMonad a = BacktrackM () a
convertGrammar :: CanonGrammar -> CanonGrammar
convertGrammar = canon2grammar . convertCanon . grammar2canon
convertCanon :: Canon -> Canon
convertCanon (Gr modules) = Gr (map (convertModule split) modules)
where split = calcSplitable modules
convertModule :: Splitable -> Module -> Module
convertModule split (Mod mtyp ext op fl defs)
= Mod mtyp ext op fl newDefs
where newDefs = solutions defMonad ()
defMonad = member defs >>= convertDef split
----------------------------------------------------------------------
-- the main conversion function
convertDef :: Splitable -> Def -> CnvMonad Def
-- converting abstract "cat" definitions
convertDef split (AbsDCat cat decls cidents)
= case splitableCat split cat of
Just newCats -> do newCat <- member newCats
return $ AbsDCat newCat decls cidents
Nothing -> do (newCat, newDecls) <- expandDecls cat decls
return $ AbsDCat newCat newDecls cidents
where expandDecls cat [] = return (cat, [])
expandDecls cat (decl@(Decl var typ) : decls)
= do (newCat, newDecls) <- expandDecls cat decls
let argCat = resultCat typ
case splitableCat split argCat of
Nothing -> return (newCat, decl : newDecls)
Just newArgs -> do newArg <- member newArgs
return (mergeArg newCat newArg, newDecls)
-- converting abstract "fun" definitions
convertDef split (AbsDFun fun typ@(EAtom (AC (CIQ mod cat))) def)
= case splitableFun split fun of
Just newCat -> return (AbsDFun fun (EAtom (AC (CIQ mod newCat))) def)
Nothing -> do newTyp <- expandType split [] typ
return (AbsDFun fun newTyp def)
convertDef split (AbsDFun fun typ def)
= do newTyp <- expandType split [] typ
return (AbsDFun fun newTyp def)
-- converting concrete "lincat" definitions
convertDef split (CncDCat cat ctype x y)
= case splitableCat split cat of
Just newCats -> do newCat <- member newCats
return $ CncDCat newCat ctype x y
Nothing -> return $ CncDCat cat ctype x y
-- converting concrete "lin" definitions
convertDef split (CncDFun fun (CIQ mod cat) args linterm x)
= case splitableFun split fun of
Just newCat -> return $ CncDFun fun (CIQ mod newCat) args linterm x
Nothing -> return $ CncDFun fun (CIQ mod cat) args linterm x
convertDef _ def = return def
----------------------------------------------------------------------
-- expanding type expressions
expandType :: Splitable -> [(Ident, Cat)] -> Exp -> CnvMonad Exp
expandType split env (EProd x a@(EAtom (AC (CIQ mod cat))) b)
= case splitableCat split cat of
Nothing -> do b' <- expandType split env b
return (EProd x a b')
Just newCats -> do newCat <- member newCats
b' <- expandType split ((x,newCat):env) b
return (EProd x (EAtom (AC (CIQ mod newCat))) b')
expandType split env (EProd x a b)
= do a' <- expandType split env a
b' <- expandType split env b
return (EProd x a' b')
expandType split env app
= expandApp split env [] app
expandApp :: Splitable -> [(Ident, Cat)] -> [Cat] -> Exp -> CnvMonad Exp
expandApp split env addons (EAtom (AC (CIQ mod cat)))
= return (EAtom (AC (CIQ mod (foldl mergeArg cat addons))))
expandApp split env addons (EApp exp arg@(EAtom (AC (CIQ mod fun))))
= case splitableFun split fun of
Just newCat -> expandApp split env (newCat:addons) exp
Nothing -> do exp' <- expandApp split env addons exp
return (EApp exp' arg)
expandApp split env addons (EApp exp arg@(EAtom (AV x)))
= case lookup x env of
Just newCat -> expandApp split env (newCat:addons) exp
Nothing -> do exp' <- expandApp split env addons exp
return (EApp exp' arg)
----------------------------------------------------------------------
-- splitable categories (finite, no dependencies)
-- they should also be used as some dependency
type Splitable = (Assoc Cat [Cat], Assoc Name Cat)
splitableCat :: Splitable -> Cat -> Maybe [Cat]
splitableCat = lookupAssoc . fst
splitableFun :: Splitable -> Name -> Maybe Cat
splitableFun = lookupAssoc . snd
calcSplitable :: [Module] -> Splitable
calcSplitable modules = (listAssoc splitableCats, listAssoc splitableFuns)
where splitableCats = tracePrt "splitableCats" (prtSep " ") $
groupPairs $ nubsort
[ (cat, mergeFun fun cat) | (cat, fun) <- constantCats ]
splitableFuns = tracePrt "splitableFuns" (prtSep " ") $
nubsort
[ (fun, mergeFun fun cat) | (cat, fun) <- constantCats ]
constantCats = tracePrt "constantCats" (prtSep " ") $
[ (cat, fun) |
AbsDFun fun (EAtom (AC (CIQ _ cat))) _ <- absDefs,
dependentConstants ?= cat ]
dependentConstants = listSet $
tracePrt "dep consts" prt $
dependentCats <\\> funCats
funCats = tracePrt "fun cats" prt $
nubsort [ resultCat typ |
AbsDFun _ typ@(EProd _ _ _) _ <- absDefs ]
dependentCats = tracePrt "dep cats" prt $
nubsort [ cat | AbsDCat _ decls _ <- absDefs,
Decl _ (EAtom (AC (CIQ _ cat))) <- decls ]
absDefs = concat [ defs | Mod (MTAbs _) _ _ _ defs <- modules ]
----------------------------------------------------------------------
-- utilities
-- the main result category of a type expression
resultCat :: Exp -> Cat
resultCat (EProd _ _ b) = resultCat b
resultCat (EApp a _) = resultCat a
resultCat (EAtom (AC (CIQ _ cat))) = cat
-- mergeing categories
mergeCats :: String -> String -> String -> Cat -> Cat -> Cat
mergeCats before middle after (IC cat) (IC arg)
= IC (before ++ cat ++ middle ++ arg ++ after)
mergeFun, mergeArg :: Cat -> Cat -> Cat
mergeFun = mergeCats "{" ":" "}"
mergeArg = mergeCats "" "" ""
----------------------------------------------------------------------
-- obsolete?
{-
type FiniteCats = Assoc Cat Integer
calculateFiniteness :: Canon -> FiniteCats
calculateFiniteness canon@(Gr modules)
= trace2 "#typeInfo" (prt tInfo) $
finiteCats
where finiteCats = listAssoc [ (cat, fin) | (cat, Just fin) <- finiteInfo ]
finiteInfo = map finInfo groups
finInfo :: (Cat, [[Cat]]) -> (Cat, Maybe Integer)
finInfo (cat, ctxts)
| cyclicCats ?= cat = (cat, Nothing)
| otherwise = (cat, fmap (sum . map product) $
sequence (map (sequence . map lookFinCat) ctxts))
lookFinCat :: Cat -> Maybe Integer
lookFinCat cat = maybe (error "lookFinCat: Nothing") id $
lookup cat finiteInfo
cyclicCats :: Set Cat
cyclicCats = listSet $
tracePrt "cyclic cats" prt $
union $ map nubsort $ cyclesIn dependencies
dependencies :: [(Cat, [Cat])]
dependencies = tracePrt "dependencies" (prtAfter "\n") $
mapSnd (union . nubsort) groups
groups :: [(Cat, [[Cat]])]
groups = tracePrt "groups" (prtAfter "\n") $
mapSnd (map snd) $ groupPairs (nubsort allFuns)
allFuns = tracePrt "all funs" (prtAfter "\n") $
[ (cat, (fun, ctxt)) |
Mod (MTAbs _) _ _ _ defs <- modules,
AbsDFun fun typ _ <- defs,
let (cat, ctxt) = err error id $ typeForm typ ]
tInfo = calculateTypeInfo 30 finiteCats (splitDefs canon)
-- | stolen from 'Macros.qTypeForm', converted to GFC, and severely simplified
typeForm :: Monad m => Exp -> m (Cat, [Cat])
typeForm t = case t of
EProd x a b -> do
(cat, ctxt) <- typeForm b
a' <- stripType a
return (cat, a':ctxt)
EApp c a -> do
(cat, _) <- typeForm c
return (cat, [])
EAtom (AC (CIQ _ con)) ->
return (con, [])
_ ->
fail $ "no normal form of type: " ++ prt t
stripType :: Monad m => Exp -> m Cat
stripType (EApp c a) = stripType c
stripType (EAtom (AC (CIQ _ con))) = return con
stripType t = fail $ "can't strip type: " ++ prt t
mapSnd f xs = [ (a, f b) | (a, b) <- xs ]
-}
----------------------------------------------------------------------
-- obsolete?
{-
type SplitDefs = ([Def], [Def], [Def], [Def])
----- AbsDCat AbsDFun CncDCat CncDFun
splitDefs :: Canon -> SplitDefs
splitDefs (Gr modules) = foldr splitDef ([], [], [], []) $
concat [ defs | Mod _ _ _ _ defs <- modules ]
splitDef :: Def -> SplitDefs -> SplitDefs
splitDef ac@(AbsDCat _ _ _) (acs, afs, ccs, cfs) = (ac:acs, afs, ccs, cfs)
splitDef af@(AbsDFun _ _ _) (acs, afs, ccs, cfs) = (acs, af:afs, ccs, cfs)
splitDef cc@(CncDCat _ _ _ _) (acs, afs, ccs, cfs) = (acs, afs, cc:ccs, cfs)
splitDef cf@(CncDFun _ _ _ _ _) (acs, afs, ccs, cfs) = (acs, afs, ccs, cf:cfs)
splitDef _ sd = sd
--calculateTypeInfo :: Integer -> FiniteCats -> SplitDefs -> ?
calculateTypeInfo maxFin allFinCats (acs, afs, ccs, cfs)
= (depCatsToExpand, catsToSplit)
where absDefsToExpand = tracePrt "absDefsToExpand" prt $
[ ((cat, fin), cats) |
AbsDCat cat args _ <- acs,
not (null args),
cats <- mapM catOfDecl args,
fin <- lookupAssoc allFinCats cat,
fin <= maxFin
]
(depCatsToExpand, argsCats') = unzip absDefsToExpand
catsToSplit = union (map nubsort argsCats')
catOfDecl (Decl _ exp) = err fail return $ stripType exp
-}
|
