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
|
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/12 10:49:44 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.2 $
--
-- 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.Conversion.Types
import GF.Data.SortedList
import GF.Data.Assoc
import GF.Data.BacktrackM
import GF.Data.Utilities (lookupList)
import Ident (Ident(..))
type CnvMonad a = BacktrackM () a
convertGrammar :: SGrammar -> SGrammar
convertGrammar rules = tracePrt "#finite simpleGFC 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
convertAbstract :: Splitable -> Abstract SDecl Name
-> CnvMonad (Abstract SDecl Name)
convertAbstract split (Abs (_ ::: typ) decls name)
= case splitableFun split (name2fun name) of
Just newCat -> return $ Abs (anyVar ::: (newCat :@ [])) decls name
Nothing -> expandTyping split name [] typ decls []
expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SType -> [SDecl] -> [SDecl]
-> CnvMonad (Abstract SDecl Name)
expandTyping split fun env (cat :@ atoms) [] decls
= return $ Abs decl (reverse decls) fun
where decl = anyVar ::: substAtoms split env cat atoms []
expandTyping split fun env typ ((x ::: (xcat :@ xatoms)) : declsToDo) declsDone
= do (xcat', env') <- calcNewEnv
let decl = x ::: substAtoms split env xcat' xatoms []
expandTyping split fun env' typ declsToDo (decl : declsDone)
where calcNewEnv = case splitableCat split xcat of
Just newCats -> do newCat <- member newCats
return (newCat, (x,newCat) : env)
Nothing -> return (xcat, env)
substAtoms :: Splitable -> [(Var, SCat)] -> SCat -> [Atom] -> [Atom] -> SType
substAtoms split env cat [] atoms = cat :@ reverse atoms
substAtoms split env cat (atom:atomsToDo) atomsDone
= case atomLookup split env atom of
Just newCat -> substAtoms split env (mergeArg cat newCat) atomsToDo atomsDone
Nothing -> substAtoms split env cat atomsToDo (atom : atomsDone)
atomLookup split env (AVar x) = lookup x env
atomLookup split env (ACon con) = splitableFun split (constr2fun con)
----------------------------------------------------------------------
-- splitable categories (finite, no dependencies)
-- they should also be used as some dependency
type Splitable = (Assoc SCat [SCat], Assoc Fun SCat)
splitableCat :: Splitable -> SCat -> Maybe [SCat]
splitableCat = lookupAssoc . fst
splitableFun :: Splitable -> Fun -> Maybe SCat
splitableFun = lookupAssoc . snd
calcSplitable :: [SRule] -> Splitable
calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat)
where splitableCat2Funs = groupPairs $ nubsort
[ (cat, mergeFun fun cat) | (cat, fun) <- splitableCatFuns ]
splitableFun2Cat = nubsort
[ (fun, mergeFun fun cat) | (cat, fun) <- splitableCatFuns ]
-- cat-fun pairs that are splitable
splitableCatFuns = [ (cat, name2fun name) |
Rule (Abs (_ ::: (cat :@ [])) [] name) _ <- rules,
splitableCats ?= cat ]
-- all cats that are splitable
splitableCats = listSet $
tracePrt "finite categories to split" prt $
(nondepCats <**> depCats) <\\> resultCats
-- all result cats for some pure function
resultCats = nubsort [ cat | Rule (Abs (_ ::: (cat :@ _)) decls _) _ <- rules,
not (null decls) ]
-- all cats in constants without dependencies
nondepCats = nubsort [ cat | Rule (Abs (_ ::: (cat :@ [])) [] _) _ <- rules ]
-- all cats occurring as some dependency of another cat
depCats = nubsort [ cat | Rule (Abs decl decls _) _ <- rules,
cat <- varCats [] (decls ++ [decl]) ]
varCats _ [] = []
varCats env ((x ::: (xcat :@ atoms)) : decls)
= varCats ((x,xcat) : env) decls ++
[ cat | AVar y <- atoms, 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 "" "" ""
|
