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
|
----------------------------------------------------------------------
-- |
-- 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.ConvertFiniteSimple
(convertGrammar) where
import GF.System.Tracing
import GF.Printing.PrintParser
import GF.Printing.PrintSimplifiedTerm
import Operations
import Ident (Ident(..))
import GF.OldParsing.SimpleGFC
import GF.Data.SortedList
import GF.Data.Assoc
import GF.Data.BacktrackM
type CnvMonad a = BacktrackM () a
convertGrammar :: Grammar -> Grammar
convertGrammar rules = solutions cnvMonad ()
where split = calcSplitable rules
cnvMonad = member rules >>= convertRule split
convertRule :: Splitable -> Rule -> CnvMonad Rule
convertRule split (Rule name typing term)
= do newTyping <- convertTyping split name typing
return $ Rule name newTyping term
convertTyping :: Splitable -> Name -> Typing -> CnvMonad Typing
convertTyping split name (typ, decls)
= case splitableFun split name of
Just newCat -> return (newCat :@ [], decls)
Nothing -> expandTyping split [] typ decls []
expandTyping :: Splitable -> [(Var, Cat)] -> Type -> [Decl] -> [Decl] -> CnvMonad Typing
expandTyping split env (cat :@ atoms) [] decls
= return (substAtoms split env cat atoms [], reverse decls)
expandTyping split env typ ((x ::: (xcat :@ xatoms)) : declsToDo) declsDone
= do env' <- calcNewEnv
expandTyping split env' typ declsToDo (decl : declsDone)
where decl = x ::: substAtoms split env xcat xatoms []
calcNewEnv = case splitableCat split xcat of
Just newCats -> do newCat <- member newCats
return ((x,newCat) : env)
Nothing -> return env
substAtoms :: Splitable -> [(Var, Cat)] -> Cat -> [Atom] -> [Atom] -> Type
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 (constr2name con)
----------------------------------------------------------------------
-- 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 :: [Rule] -> Splitable
calcSplitable rules = (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) |
Rule fun (cat :@ [], []) _ <- rules,
dependentConstants ?= cat ]
dependentConstants = listSet $
tracePrt "dep consts" prt $
dependentCats <\\> funCats
funCats = tracePrt "fun cats" prt $
nubsort [ cat | Rule _ (cat :@ _, decls) _ <- rules,
not (null decls) ]
dependentCats = tracePrt "dep cats" prt $
nubsort [ cat | Rule _ (cat :@ [], []) _ <- rules ]
----------------------------------------------------------------------
-- utilities
-- 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 "" "" ""
|
